3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13 * it has not been hard for me to read your mind and memory.'
15 * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
18 /* This file contains utility routines to dump the contents of SV and OP
19 * structures, as used by command-line options like -Dt and -Dx, and
22 * It also holds the debugging version of the runops function.
26 #define PERL_IN_DUMP_C
32 static const char* const svtypenames[SVt_LAST] = {
52 static const char* const svshorttypenames[SVt_LAST] = {
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78 const struct flag_to_name *const end)
81 if (flags & start->flag)
82 sv_catpv(sv, start->name);
83 } while (++start < end);
86 #define append_flags(sv, f, flags) \
87 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
92 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
95 PERL_ARGS_ASSERT_DUMP_INDENT;
97 dump_vindent(level, file, pat, &args);
102 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
105 PERL_ARGS_ASSERT_DUMP_VINDENT;
106 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
107 PerlIO_vprintf(file, pat, *args);
113 dump_all_perl(FALSE);
117 Perl_dump_all_perl(pTHX_ bool justperl)
121 PerlIO_setlinebuf(Perl_debug_log);
123 op_dump(PL_main_root);
124 dump_packsubs_perl(PL_defstash, justperl);
128 Perl_dump_packsubs(pTHX_ const HV *stash)
130 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
131 dump_packsubs_perl(stash, FALSE);
135 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
140 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
144 for (i = 0; i <= (I32) HvMAX(stash); i++) {
146 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
147 const GV * const gv = (const GV *)HeVAL(entry);
148 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
151 dump_sub_perl(gv, justperl);
154 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
155 const HV * const hv = GvHV(gv);
156 if (hv && (hv != PL_defstash))
157 dump_packsubs_perl(hv, justperl); /* nested package */
164 Perl_dump_sub(pTHX_ const GV *gv)
166 PERL_ARGS_ASSERT_DUMP_SUB;
167 dump_sub_perl(gv, FALSE);
171 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
175 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
177 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
181 gv_fullname3(sv, gv, NULL);
182 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
183 if (CvISXSUB(GvCV(gv)))
184 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
185 PTR2UV(CvXSUB(GvCV(gv))),
186 (int)CvXSUBANY(GvCV(gv)).any_i32);
187 else if (CvROOT(GvCV(gv)))
188 op_dump(CvROOT(GvCV(gv)));
190 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
194 Perl_dump_form(pTHX_ const GV *gv)
196 SV * const sv = sv_newmortal();
198 PERL_ARGS_ASSERT_DUMP_FORM;
200 gv_fullname3(sv, gv, NULL);
201 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
202 if (CvROOT(GvFORM(gv)))
203 op_dump(CvROOT(GvFORM(gv)));
205 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
212 op_dump(PL_eval_root);
217 =for apidoc pv_escape
219 Escapes at most the first "count" chars of pv and puts the results into
220 dsv such that the size of the escaped string will not exceed "max" chars
221 and will not contain any incomplete escape sequences.
223 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
224 will also be escaped.
226 Normally the SV will be cleared before the escaped string is prepared,
227 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
229 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
230 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
231 using C<is_utf8_string()> to determine if it is Unicode.
233 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
234 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
235 chars above 127 will be escaped using this style; otherwise, only chars above
236 255 will be so escaped; other non printable chars will use octal or
237 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
238 then all chars below 255 will be treated as printable and
239 will be output as literals.
241 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
242 string will be escaped, regardless of max. If the output is to be in hex,
243 then it will be returned as a plain hex
244 sequence. Thus the output will either be a single char,
245 an octal escape sequence, a special escape like C<\n> or a hex value.
247 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
248 not a '\\'. This is because regexes very often contain backslashed
249 sequences, whereas '%' is not a particularly common character in patterns.
251 Returns a pointer to the escaped text as held by dsv.
255 #define PV_ESCAPE_OCTBUFSIZE 32
258 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
259 const STRLEN count, const STRLEN max,
260 STRLEN * const escaped, const U32 flags )
262 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
263 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
264 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
265 STRLEN wrote = 0; /* chars written so far */
266 STRLEN chsize = 0; /* size of data to be written */
267 STRLEN readsize = 1; /* size of data just read */
268 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
269 const char *pv = str;
270 const char * const end = pv + count; /* end of string */
273 PERL_ARGS_ASSERT_PV_ESCAPE;
275 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
276 /* This won't alter the UTF-8 flag */
280 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
283 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
284 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
285 const U8 c = (U8)u & 0xFF;
288 || (flags & PERL_PV_ESCAPE_ALL)
289 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
291 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
292 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
295 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
296 "%cx{%"UVxf"}", esc, u);
297 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
300 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
304 case '\\' : /* fallthrough */
305 case '%' : if ( c == esc ) {
311 case '\v' : octbuf[1] = 'v'; break;
312 case '\t' : octbuf[1] = 't'; break;
313 case '\r' : octbuf[1] = 'r'; break;
314 case '\n' : octbuf[1] = 'n'; break;
315 case '\f' : octbuf[1] = 'f'; break;
323 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
324 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
327 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
334 if ( max && (wrote + chsize > max) ) {
336 } else if (chsize > 1) {
337 sv_catpvn(dsv, octbuf, chsize);
340 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
341 128-255 can be appended raw to the dsv. If dsv happens to be
342 UTF-8 then we need catpvf to upgrade them for us.
343 Or add a new API call sv_catpvc(). Think about that name, and
344 how to keep it clear that it's unlike the s of catpvs, which is
345 really an array octets, not a string. */
346 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
349 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
357 =for apidoc pv_pretty
359 Converts a string into something presentable, handling escaping via
360 pv_escape() and supporting quoting and ellipses.
362 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
363 double quoted with any double quotes in the string escaped. Otherwise
364 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
367 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
368 string were output then an ellipsis C<...> will be appended to the
369 string. Note that this happens AFTER it has been quoted.
371 If start_color is non-null then it will be inserted after the opening
372 quote (if there is one) but before the escaped text. If end_color
373 is non-null then it will be inserted after the escaped text but before
374 any quotes or ellipses.
376 Returns a pointer to the prettified text as held by dsv.
382 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
383 const STRLEN max, char const * const start_color, char const * const end_color,
386 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
389 PERL_ARGS_ASSERT_PV_PRETTY;
391 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
392 /* This won't alter the UTF-8 flag */
397 sv_catpvs(dsv, "\"");
398 else if ( flags & PERL_PV_PRETTY_LTGT )
401 if ( start_color != NULL )
402 sv_catpv(dsv, start_color);
404 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
406 if ( end_color != NULL )
407 sv_catpv(dsv, end_color);
410 sv_catpvs( dsv, "\"");
411 else if ( flags & PERL_PV_PRETTY_LTGT )
414 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
415 sv_catpvs(dsv, "...");
421 =for apidoc pv_display
425 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
427 except that an additional "\0" will be appended to the string when
428 len > cur and pv[cur] is "\0".
430 Note that the final string may be up to 7 chars longer than pvlim.
436 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
438 PERL_ARGS_ASSERT_PV_DISPLAY;
440 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
441 if (len > cur && pv[cur] == '\0')
442 sv_catpvs( dsv, "\\0");
447 Perl_sv_peek(pTHX_ SV *sv)
450 SV * const t = sv_newmortal();
460 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
464 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
465 if (sv == &PL_sv_undef) {
466 sv_catpv(t, "SV_UNDEF");
467 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
468 SVs_GMG|SVs_SMG|SVs_RMG)) &&
472 else if (sv == &PL_sv_no) {
473 sv_catpv(t, "SV_NO");
474 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
475 SVs_GMG|SVs_SMG|SVs_RMG)) &&
476 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
482 else if (sv == &PL_sv_yes) {
483 sv_catpv(t, "SV_YES");
484 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
485 SVs_GMG|SVs_SMG|SVs_RMG)) &&
486 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
489 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
494 sv_catpv(t, "SV_PLACEHOLDER");
495 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
496 SVs_GMG|SVs_SMG|SVs_RMG)) &&
502 else if (SvREFCNT(sv) == 0) {
506 else if (DEBUG_R_TEST_) {
509 /* is this SV on the tmps stack? */
510 for (ix=PL_tmps_ix; ix>=0; ix--) {
511 if (PL_tmps_stack[ix] == sv) {
516 if (SvREFCNT(sv) > 1)
517 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
525 if (SvCUR(t) + unref > 10) {
526 SvCUR_set(t, unref + 3);
535 if (type == SVt_PVCV) {
536 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
538 } else if (type < SVt_LAST) {
539 sv_catpv(t, svshorttypenames[type]);
541 if (type == SVt_NULL)
544 sv_catpv(t, "FREED");
549 if (!SvPVX_const(sv))
550 sv_catpv(t, "(null)");
552 SV * const tmp = newSVpvs("");
556 SvOOK_offset(sv, delta);
557 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
559 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
561 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
562 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
567 else if (SvNOKp(sv)) {
568 STORE_NUMERIC_LOCAL_SET_STANDARD();
569 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
570 RESTORE_NUMERIC_LOCAL();
572 else if (SvIOKp(sv)) {
574 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
576 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
584 if (PL_tainting && SvTAINTED(sv))
585 sv_catpv(t, " [tainted]");
586 return SvPV_nolen(t);
590 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
594 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
597 Perl_dump_indent(aTHX_ level, file, "{}\n");
600 Perl_dump_indent(aTHX_ level, file, "{\n");
602 if (pm->op_pmflags & PMf_ONCE)
607 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
608 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
609 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
611 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
612 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
613 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
614 op_dump(pm->op_pmreplrootu.op_pmreplroot);
616 if (pm->op_code_list) {
617 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
618 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
619 do_op_dump(level, file, pm->op_code_list);
622 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
623 PTR2UV(pm->op_code_list));
625 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
626 SV * const tmpsv = pm_description(pm);
627 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
631 Perl_dump_indent(aTHX_ level-1, file, "}\n");
634 const struct flag_to_name pmflags_flags_names[] = {
635 {PMf_CONST, ",CONST"},
637 {PMf_GLOBAL, ",GLOBAL"},
638 {PMf_CONTINUE, ",CONTINUE"},
639 {PMf_RETAINT, ",RETAINT"},
641 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
642 {PMf_HAS_CV, ",HAS_CV"},
643 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
644 {PMf_IS_QR, ",IS_QR"}
648 S_pm_description(pTHX_ const PMOP *pm)
650 SV * const desc = newSVpvs("");
651 const REGEXP * const regex = PM_GETRE(pm);
652 const U32 pmflags = pm->op_pmflags;
654 PERL_ARGS_ASSERT_PM_DESCRIPTION;
656 if (pmflags & PMf_ONCE)
657 sv_catpv(desc, ",ONCE");
659 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
660 sv_catpv(desc, ":USED");
662 if (pmflags & PMf_USED)
663 sv_catpv(desc, ":USED");
667 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
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 #define OP_PRIVATE_ONCE(op, flag, name) \
775 const struct flag_to_name CAT2(op, _names)[] = { \
779 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
780 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
781 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
782 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
783 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
784 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
785 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
786 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
787 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
788 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
789 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
790 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
792 struct op_private_by_op {
795 const struct flag_to_name *start;
798 const struct op_private_by_op op_private_names[] = {
799 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
800 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
801 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
802 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_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);
841 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
845 const OPCODE optype = o->op_type;
847 PERL_ARGS_ASSERT_DO_OP_DUMP;
849 Perl_dump_indent(aTHX_ level, file, "{\n");
851 seq = sequence_num(o);
853 PerlIO_printf(file, "%-4"UVuf, seq);
855 PerlIO_printf(file, "????");
857 "%*sTYPE = %s ===> ",
858 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
861 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
862 sequence_num(o->op_next));
864 PerlIO_printf(file, "NULL\n");
866 if (optype == OP_NULL) {
867 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
868 if (o->op_targ == OP_NEXTSTATE) {
870 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
872 if (CopSTASHPV(cCOPo))
873 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
876 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
881 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
884 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
886 if (o->op_flags || o->op_slabbed || o->op_savefree) {
887 SV * const tmpsv = newSVpvs("");
888 switch (o->op_flags & OPf_WANT) {
890 sv_catpv(tmpsv, ",VOID");
892 case OPf_WANT_SCALAR:
893 sv_catpv(tmpsv, ",SCALAR");
896 sv_catpv(tmpsv, ",LIST");
899 sv_catpv(tmpsv, ",UNKNOWN");
902 append_flags(tmpsv, o->op_flags, op_flags_names);
903 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
904 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
905 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
909 SV * const tmpsv = newSVpvs("");
910 if (PL_opargs[optype] & OA_TARGLEX) {
911 if (o->op_private & OPpTARGET_MY)
912 sv_catpv(tmpsv, ",TARGET_MY");
914 else if (optype == OP_ENTERSUB ||
915 optype == OP_RV2SV ||
917 optype == OP_RV2AV ||
918 optype == OP_RV2HV ||
919 optype == OP_RV2GV ||
920 optype == OP_AELEM ||
923 if (optype == OP_ENTERSUB) {
924 append_flags(tmpsv, o->op_private, op_entersub_names);
927 switch (o->op_private & OPpDEREF) {
929 sv_catpv(tmpsv, ",SV");
932 sv_catpv(tmpsv, ",AV");
935 sv_catpv(tmpsv, ",HV");
938 if (o->op_private & OPpMAYBE_LVSUB)
939 sv_catpv(tmpsv, ",MAYBE_LVSUB");
942 if (optype == OP_AELEM || optype == OP_HELEM) {
943 if (o->op_private & OPpLVAL_DEFER)
944 sv_catpv(tmpsv, ",LVAL_DEFER");
946 else if (optype == OP_RV2HV || optype == OP_PADHV) {
947 if (o->op_private & OPpMAYBE_TRUEBOOL)
948 sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL");
949 if (o->op_private & OPpTRUEBOOL)
950 sv_catpvs(tmpsv, ",OPpTRUEBOOL");
953 if (o->op_private & HINT_STRICT_REFS)
954 sv_catpv(tmpsv, ",STRICT_REFS");
955 if (o->op_private & OPpOUR_INTRO)
956 sv_catpv(tmpsv, ",OUR_INTRO");
959 else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
961 else if (PL_check[optype] != Perl_ck_ftst) {
962 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
963 sv_catpv(tmpsv, ",FT_ACCESS");
964 if (o->op_private & OPpFT_STACKED)
965 sv_catpv(tmpsv, ",FT_STACKED");
967 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
968 sv_catpv(tmpsv, ",INTRO");
970 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
975 if (PL_madskills && o->op_madprop) {
976 SV * const tmpsv = newSVpvs("");
977 MADPROP* mp = o->op_madprop;
978 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
981 const char tmp = mp->mad_key;
982 sv_setpvs(tmpsv,"'");
984 sv_catpvn(tmpsv, &tmp, 1);
985 sv_catpv(tmpsv, "'=");
986 switch (mp->mad_type) {
988 sv_catpv(tmpsv, "NULL");
989 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
992 sv_catpv(tmpsv, "<");
993 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
994 sv_catpv(tmpsv, ">");
995 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
998 if ((OP*)mp->mad_val) {
999 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1000 do_op_dump(level, file, (OP*)mp->mad_val);
1004 sv_catpv(tmpsv, "(UNK)");
1005 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1011 Perl_dump_indent(aTHX_ level, file, "}\n");
1013 SvREFCNT_dec(tmpsv);
1022 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1024 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1025 if (cSVOPo->op_sv) {
1026 SV * const tmpsv = newSV(0);
1030 /* FIXME - is this making unwarranted assumptions about the
1031 UTF-8 cleanliness of the dump file handle? */
1034 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1035 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1036 SvPV_nolen_const(tmpsv));
1040 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1046 case OP_METHOD_NAMED:
1047 #ifndef USE_ITHREADS
1048 /* with ITHREADS, consts are stored in the pad, and the right pad
1049 * may not be active here, so skip */
1050 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1056 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1057 (UV)CopLINE(cCOPo));
1058 if (CopSTASHPV(cCOPo))
1059 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1061 if (CopLABEL(cCOPo))
1062 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1066 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1067 if (cLOOPo->op_redoop)
1068 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1070 PerlIO_printf(file, "DONE\n");
1071 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1072 if (cLOOPo->op_nextop)
1073 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1075 PerlIO_printf(file, "DONE\n");
1076 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1077 if (cLOOPo->op_lastop)
1078 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1080 PerlIO_printf(file, "DONE\n");
1088 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1089 if (cLOGOPo->op_other)
1090 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1092 PerlIO_printf(file, "DONE\n");
1098 do_pmop_dump(level, file, cPMOPo);
1106 if (o->op_private & OPpREFCOUNTED)
1107 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1112 if (o->op_flags & OPf_KIDS) {
1114 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1115 do_op_dump(level, file, kid);
1117 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1121 Perl_op_dump(pTHX_ const OP *o)
1123 PERL_ARGS_ASSERT_OP_DUMP;
1124 do_op_dump(0, Perl_debug_log, o);
1128 Perl_gv_dump(pTHX_ GV *gv)
1132 PERL_ARGS_ASSERT_GV_DUMP;
1135 PerlIO_printf(Perl_debug_log, "{}\n");
1138 sv = sv_newmortal();
1139 PerlIO_printf(Perl_debug_log, "{\n");
1140 gv_fullname3(sv, gv, NULL);
1141 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1142 if (gv != GvEGV(gv)) {
1143 gv_efullname3(sv, GvEGV(gv), NULL);
1144 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1146 PerlIO_putc(Perl_debug_log, '\n');
1147 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1151 /* map magic types to the symbolic names
1152 * (with the PERL_MAGIC_ prefixed stripped)
1155 static const struct { const char type; const char *name; } magic_names[] = {
1156 #include "mg_names.c"
1157 /* this null string terminates the list */
1162 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1164 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1166 for (; mg; mg = mg->mg_moremagic) {
1167 Perl_dump_indent(aTHX_ level, file,
1168 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1169 if (mg->mg_virtual) {
1170 const MGVTBL * const v = mg->mg_virtual;
1171 if (v >= PL_magic_vtables
1172 && v < PL_magic_vtables + magic_vtable_max) {
1173 const U32 i = v - PL_magic_vtables;
1174 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1177 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1180 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1183 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1187 const char *name = NULL;
1188 for (n = 0; magic_names[n].name; n++) {
1189 if (mg->mg_type == magic_names[n].type) {
1190 name = magic_names[n].name;
1195 Perl_dump_indent(aTHX_ level, file,
1196 " MG_TYPE = PERL_MAGIC_%s\n", name);
1198 Perl_dump_indent(aTHX_ level, file,
1199 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1203 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1204 if (mg->mg_type == PERL_MAGIC_envelem &&
1205 mg->mg_flags & MGf_TAINTEDDIR)
1206 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1207 if (mg->mg_type == PERL_MAGIC_regex_global &&
1208 mg->mg_flags & MGf_MINMATCH)
1209 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1210 if (mg->mg_flags & MGf_REFCOUNTED)
1211 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1212 if (mg->mg_flags & MGf_GSKIP)
1213 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1214 if (mg->mg_flags & MGf_COPY)
1215 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1216 if (mg->mg_flags & MGf_DUP)
1217 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1218 if (mg->mg_flags & MGf_LOCAL)
1219 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1222 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1223 PTR2UV(mg->mg_obj));
1224 if (mg->mg_type == PERL_MAGIC_qr) {
1225 REGEXP* const re = (REGEXP *)mg->mg_obj;
1226 SV * const dsv = sv_newmortal();
1227 const char * const s
1228 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1230 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1231 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1233 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1234 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1237 if (mg->mg_flags & MGf_REFCOUNTED)
1238 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1241 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1243 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1244 if (mg->mg_len >= 0) {
1245 if (mg->mg_type != PERL_MAGIC_utf8) {
1246 SV * const sv = newSVpvs("");
1247 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1251 else if (mg->mg_len == HEf_SVKEY) {
1252 PerlIO_puts(file, " => HEf_SVKEY\n");
1253 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1254 maxnest, dumpops, pvlim); /* MG is already +1 */
1257 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1262 " does not know how to handle this MG_LEN"
1264 PerlIO_putc(file, '\n');
1266 if (mg->mg_type == PERL_MAGIC_utf8) {
1267 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1270 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1271 Perl_dump_indent(aTHX_ level, file,
1272 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1275 (UV)cache[i * 2 + 1]);
1282 Perl_magic_dump(pTHX_ const MAGIC *mg)
1284 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1288 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1292 PERL_ARGS_ASSERT_DO_HV_DUMP;
1294 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1295 if (sv && (hvname = HvNAME_get(sv)))
1297 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1298 name which quite legally could contain insane things like tabs, newlines, nulls or
1299 other scary crap - this should produce sane results - except maybe for unicode package
1300 names - but we will wait for someone to file a bug on that - demerphq */
1301 SV * const tmpsv = newSVpvs("");
1302 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1305 PerlIO_putc(file, '\n');
1309 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1311 PERL_ARGS_ASSERT_DO_GV_DUMP;
1313 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1314 if (sv && GvNAME(sv))
1315 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1317 PerlIO_putc(file, '\n');
1321 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1323 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1325 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1326 if (sv && GvNAME(sv)) {
1328 PerlIO_printf(file, "\t\"");
1329 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1330 PerlIO_printf(file, "%s\" :: \"", hvname);
1331 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1334 PerlIO_putc(file, '\n');
1337 const struct flag_to_name first_sv_flags_names[] = {
1338 {SVs_TEMP, "TEMP,"},
1339 {SVs_OBJECT, "OBJECT,"},
1348 const struct flag_to_name second_sv_flags_names[] = {
1350 {SVf_FAKE, "FAKE,"},
1351 {SVf_READONLY, "READONLY,"},
1352 {SVf_BREAK, "BREAK,"},
1353 {SVf_AMAGIC, "OVERLOAD,"},
1359 const struct flag_to_name cv_flags_names[] = {
1360 {CVf_ANON, "ANON,"},
1361 {CVf_UNIQUE, "UNIQUE,"},
1362 {CVf_CLONE, "CLONE,"},
1363 {CVf_CLONED, "CLONED,"},
1364 {CVf_CONST, "CONST,"},
1365 {CVf_NODEBUG, "NODEBUG,"},
1366 {CVf_LVALUE, "LVALUE,"},
1367 {CVf_METHOD, "METHOD,"},
1368 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1369 {CVf_CVGV_RC, "CVGV_RC,"},
1370 {CVf_DYNFILE, "DYNFILE,"},
1371 {CVf_AUTOLOAD, "AUTOLOAD,"},
1372 {CVf_HASEVAL, "HASEVAL"},
1373 {CVf_SLABBED, "SLABBED,"},
1374 {CVf_ISXSUB, "ISXSUB,"}
1377 const struct flag_to_name hv_flags_names[] = {
1378 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1379 {SVphv_LAZYDEL, "LAZYDEL,"},
1380 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1381 {SVphv_REHASH, "REHASH,"},
1382 {SVphv_CLONEABLE, "CLONEABLE,"}
1385 const struct flag_to_name gp_flags_names[] = {
1386 {GVf_INTRO, "INTRO,"},
1387 {GVf_MULTI, "MULTI,"},
1388 {GVf_ASSUMECV, "ASSUMECV,"},
1389 {GVf_IN_PAD, "IN_PAD,"}
1392 const struct flag_to_name gp_flags_imported_names[] = {
1393 {GVf_IMPORTED_SV, " SV"},
1394 {GVf_IMPORTED_AV, " AV"},
1395 {GVf_IMPORTED_HV, " HV"},
1396 {GVf_IMPORTED_CV, " CV"},
1399 const struct flag_to_name regexp_flags_names[] = {
1400 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1401 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1402 {RXf_PMf_FOLD, "PMf_FOLD,"},
1403 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1404 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1405 {RXf_ANCH_BOL, "ANCH_BOL,"},
1406 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1407 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1408 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1409 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1410 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1411 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1412 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1413 {RXf_CANY_SEEN, "CANY_SEEN,"},
1414 {RXf_NOSCAN, "NOSCAN,"},
1415 {RXf_CHECK_ALL, "CHECK_ALL,"},
1416 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1417 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1418 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1419 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1420 {RXf_SPLIT, "SPLIT,"},
1421 {RXf_COPY_DONE, "COPY_DONE,"},
1422 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1423 {RXf_TAINTED, "TAINTED,"},
1424 {RXf_START_ONLY, "START_ONLY,"},
1425 {RXf_SKIPWHITE, "SKIPWHITE,"},
1426 {RXf_WHITE, "WHITE,"},
1427 {RXf_NULL, "NULL,"},
1431 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1439 PERL_ARGS_ASSERT_DO_SV_DUMP;
1442 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1446 flags = SvFLAGS(sv);
1449 /* process general SV flags */
1451 d = Perl_newSVpvf(aTHX_
1452 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1453 PTR2UV(SvANY(sv)), PTR2UV(sv),
1454 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1455 (int)(PL_dumpindent*level), "");
1457 if (!((flags & SVpad_NAME) == SVpad_NAME
1458 && (type == SVt_PVMG || type == SVt_PVNV))) {
1459 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1460 sv_catpv(d, "PADSTALE,");
1462 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1463 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1464 sv_catpv(d, "PADTMP,");
1465 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1467 append_flags(d, flags, first_sv_flags_names);
1468 if (flags & SVf_ROK) {
1469 sv_catpv(d, "ROK,");
1470 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1472 append_flags(d, flags, second_sv_flags_names);
1473 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1474 if (SvPCS_IMPORTED(sv))
1475 sv_catpv(d, "PCS_IMPORTED,");
1477 sv_catpv(d, "SCREAM,");
1480 /* process type-specific SV flags */
1485 append_flags(d, CvFLAGS(sv), cv_flags_names);
1488 append_flags(d, flags, hv_flags_names);
1492 if (isGV_with_GP(sv)) {
1493 append_flags(d, GvFLAGS(sv), gp_flags_names);
1495 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1496 sv_catpv(d, "IMPORT");
1497 if (GvIMPORTED(sv) == GVf_IMPORTED)
1498 sv_catpv(d, "ALL,");
1501 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1508 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1509 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1512 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1513 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1514 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1515 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1518 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1523 /* SVphv_SHAREKEYS is also 0x20000000 */
1524 if ((type != SVt_PVHV) && SvUTF8(sv))
1525 sv_catpv(d, "UTF8");
1527 if (*(SvEND(d) - 1) == ',') {
1528 SvCUR_set(d, SvCUR(d) - 1);
1529 SvPVX(d)[SvCUR(d)] = '\0';
1534 /* dump initial SV details */
1536 #ifdef DEBUG_LEAKING_SCALARS
1537 Perl_dump_indent(aTHX_ level, file,
1538 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1539 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1541 sv->sv_debug_inpad ? "for" : "by",
1542 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1543 PTR2UV(sv->sv_debug_parent),
1547 Perl_dump_indent(aTHX_ level, file, "SV = ");
1551 if (type < SVt_LAST) {
1552 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1554 if (type == SVt_NULL) {
1559 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1564 /* Dump general SV fields */
1566 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1567 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1568 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1569 || (type == SVt_IV && !SvROK(sv))) {
1571 #ifdef PERL_OLD_COPY_ON_WRITE
1575 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1577 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1578 #ifdef PERL_OLD_COPY_ON_WRITE
1579 if (SvIsCOW_shared_hash(sv))
1580 PerlIO_printf(file, " (HASH)");
1581 else if (SvIsCOW_normal(sv))
1582 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1584 PerlIO_putc(file, '\n');
1587 if ((type == SVt_PVNV || type == SVt_PVMG)
1588 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1589 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1590 (UV) COP_SEQ_RANGE_LOW(sv));
1591 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1592 (UV) COP_SEQ_RANGE_HIGH(sv));
1593 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1594 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1595 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1596 || type == SVt_NV) {
1597 STORE_NUMERIC_LOCAL_SET_STANDARD();
1598 /* %Vg doesn't work? --jhi */
1599 #ifdef USE_LONG_DOUBLE
1600 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1602 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1604 RESTORE_NUMERIC_LOCAL();
1608 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1610 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1613 if (type < SVt_PV) {
1618 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1619 if (SvPVX_const(sv)) {
1622 SvOOK_offset(sv, delta);
1623 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1628 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1630 PerlIO_printf(file, "( %s . ) ",
1631 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1634 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1635 if (SvUTF8(sv)) /* the 6? \x{....} */
1636 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1637 PerlIO_printf(file, "\n");
1638 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1639 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1642 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1645 if (type >= SVt_PVMG) {
1646 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1647 HV * const ost = SvOURSTASH(sv);
1649 do_hv_dump(level, file, " OURSTASH", ost);
1652 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1655 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1657 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1658 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1659 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1660 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1664 /* Dump type-specific SV fields */
1668 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1669 if (AvARRAY(sv) != AvALLOC(sv)) {
1670 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1671 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1674 PerlIO_putc(file, '\n');
1675 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1676 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1677 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1679 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1680 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1681 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1682 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1683 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1685 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1686 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1688 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1690 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1695 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1696 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1697 /* Show distribution of HEs in the ARRAY */
1699 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1702 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1703 NV theoret, sum = 0;
1705 PerlIO_printf(file, " (");
1706 Zero(freq, FREQ_MAX + 1, int);
1707 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1710 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1712 if (count > FREQ_MAX)
1718 for (i = 0; i <= max; i++) {
1720 PerlIO_printf(file, "%d%s:%d", i,
1721 (i == FREQ_MAX) ? "+" : "",
1724 PerlIO_printf(file, ", ");
1727 PerlIO_putc(file, ')');
1728 /* The "quality" of a hash is defined as the total number of
1729 comparisons needed to access every element once, relative
1730 to the expected number needed for a random hash.
1732 The total number of comparisons is equal to the sum of
1733 the squares of the number of entries in each bucket.
1734 For a random hash of n keys into k buckets, the expected
1739 for (i = max; i > 0; i--) { /* Precision: count down. */
1740 sum += freq[i] * i * i;
1742 while ((keys = keys >> 1))
1744 theoret = HvUSEDKEYS(sv);
1745 theoret += theoret * (theoret-1)/pow2;
1746 PerlIO_putc(file, '\n');
1747 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1749 PerlIO_putc(file, '\n');
1750 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1751 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1752 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1753 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1754 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1756 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1757 if (mg && mg->mg_obj) {
1758 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1762 const char * const hvname = HvNAME_get(sv);
1764 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1768 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1769 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1770 if (HvAUX(sv)->xhv_name_count)
1771 Perl_dump_indent(aTHX_
1772 level, file, " NAMECOUNT = %"IVdf"\n",
1773 (IV)HvAUX(sv)->xhv_name_count
1775 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1776 const I32 count = HvAUX(sv)->xhv_name_count;
1778 SV * const names = newSVpvs_flags("", SVs_TEMP);
1779 /* The starting point is the first element if count is
1780 positive and the second element if count is negative. */
1781 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1782 + (count < 0 ? 1 : 0);
1783 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1784 + (count < 0 ? -count : count);
1785 while (hekp < endp) {
1787 sv_catpvs(names, ", \"");
1788 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1789 sv_catpvs(names, "\"");
1791 /* This should never happen. */
1792 sv_catpvs(names, ", (null)");
1796 Perl_dump_indent(aTHX_
1797 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1801 Perl_dump_indent(aTHX_
1802 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1806 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1808 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1812 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1813 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1814 (int)meta->mro_which->length,
1815 meta->mro_which->name,
1816 PTR2UV(meta->mro_which));
1817 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1818 (UV)meta->cache_gen);
1819 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1821 if (meta->mro_linear_all) {
1822 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1823 PTR2UV(meta->mro_linear_all));
1824 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1827 if (meta->mro_linear_current) {
1828 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1829 PTR2UV(meta->mro_linear_current));
1830 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1833 if (meta->mro_nextmethod) {
1834 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1835 PTR2UV(meta->mro_nextmethod));
1836 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1840 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1842 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1847 if (nest < maxnest) {
1848 HV * const hv = MUTABLE_HV(sv);
1853 int count = maxnest - nest;
1854 for (i=0; i <= HvMAX(hv); i++) {
1855 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1862 if (count-- <= 0) goto DONEHV;
1865 keysv = hv_iterkeysv(he);
1866 keypv = SvPV_const(keysv, len);
1869 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1871 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1872 if (HvEITER_get(hv) == he)
1873 PerlIO_printf(file, "[CURRENT] ");
1875 PerlIO_printf(file, "[REHASH] ");
1876 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1877 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1886 if (CvAUTOLOAD(sv)) {
1888 const char *const name = SvPV_const(sv, len);
1889 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1893 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1894 (int) CvPROTOLEN(sv), CvPROTO(sv));
1898 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1899 if (!CvISXSUB(sv)) {
1901 Perl_dump_indent(aTHX_ level, file,
1902 " START = 0x%"UVxf" ===> %"IVdf"\n",
1903 PTR2UV(CvSTART(sv)),
1904 (IV)sequence_num(CvSTART(sv)));
1906 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1907 PTR2UV(CvROOT(sv)));
1908 if (CvROOT(sv) && dumpops) {
1909 do_op_dump(level+1, file, CvROOT(sv));
1912 SV * const constant = cv_const_sv((const CV *)sv);
1914 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1917 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1919 PTR2UV(CvXSUBANY(sv).any_ptr));
1920 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1923 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1924 (IV)CvXSUBANY(sv).any_i32);
1928 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1929 HEK_KEY(CvNAME_HEK((CV *)sv)));
1930 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1931 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1932 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1933 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1934 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1935 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1936 if (nest < maxnest) {
1937 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1940 const CV * const outside = CvOUTSIDE(sv);
1941 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1944 : CvANON(outside) ? "ANON"
1945 : (outside == PL_main_cv) ? "MAIN"
1946 : CvUNIQUE(outside) ? "UNIQUE"
1947 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1949 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1950 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1955 if (type == SVt_PVLV) {
1956 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1957 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1958 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1959 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1960 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
1961 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1962 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1965 if (!isGV_with_GP(sv))
1967 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1968 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1969 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1970 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1973 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1974 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1975 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1976 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1977 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1978 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1979 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1980 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1981 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1982 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1983 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1984 do_gv_dump (level, file, " EGV", GvEGV(sv));
1987 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1988 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1989 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1990 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1991 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1992 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1993 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1995 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1996 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1997 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1999 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2000 PTR2UV(IoTOP_GV(sv)));
2001 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2002 maxnest, dumpops, pvlim);
2004 /* Source filters hide things that are not GVs in these three, so let's
2005 be careful out there. */
2007 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2008 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2009 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2011 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2012 PTR2UV(IoFMT_GV(sv)));
2013 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2014 maxnest, dumpops, pvlim);
2016 if (IoBOTTOM_NAME(sv))
2017 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2018 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2019 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2021 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2022 PTR2UV(IoBOTTOM_GV(sv)));
2023 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2024 maxnest, dumpops, pvlim);
2026 if (isPRINT(IoTYPE(sv)))
2027 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2029 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2030 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2034 struct regexp * const r = (struct regexp *)SvANY(sv);
2035 flags = RX_EXTFLAGS((REGEXP*)sv);
2037 append_flags(d, flags, regexp_flags_names);
2038 if (*(SvEND(d) - 1) == ',') {
2039 SvCUR_set(d, SvCUR(d) - 1);
2040 SvPVX(d)[SvCUR(d)] = '\0';
2042 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2043 (UV)flags, SvPVX_const(d));
2044 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2046 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2048 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2049 (UV)(r->lastparen));
2050 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2051 (UV)(r->lastcloseparen));
2052 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2054 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2055 (IV)(r->minlenret));
2056 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2058 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2059 (UV)(r->pre_prefix));
2060 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2062 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2063 (IV)(r->suboffset));
2064 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2065 (IV)(r->subcoffset));
2067 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2069 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2071 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2072 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2074 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2075 PTR2UV(r->mother_re));
2076 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2077 PTR2UV(r->paren_names));
2078 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2079 PTR2UV(r->substrs));
2080 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2081 PTR2UV(r->pprivate));
2082 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2084 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2085 PTR2UV(r->qr_anoncv));
2086 #ifdef PERL_OLD_COPY_ON_WRITE
2087 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2088 PTR2UV(r->saved_copy));
2097 Perl_sv_dump(pTHX_ SV *sv)
2101 PERL_ARGS_ASSERT_SV_DUMP;
2104 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2106 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2110 Perl_runops_debug(pTHX)
2114 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2118 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2121 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2122 PerlIO_printf(Perl_debug_log,
2123 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2124 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2125 PTR2UV(*PL_watchaddr));
2126 if (DEBUG_s_TEST_) {
2127 if (DEBUG_v_TEST_) {
2128 PerlIO_printf(Perl_debug_log, "\n");
2136 if (DEBUG_t_TEST_) debop(PL_op);
2137 if (DEBUG_P_TEST_) debprof(PL_op);
2140 OP_ENTRY_PROBE(OP_NAME(PL_op));
2141 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2142 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2149 Perl_debop(pTHX_ const OP *o)
2153 PERL_ARGS_ASSERT_DEBOP;
2155 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2158 Perl_deb(aTHX_ "%s", OP_NAME(o));
2159 switch (o->op_type) {
2162 /* With ITHREADS, consts are stored in the pad, and the right pad
2163 * may not be active here, so check.
2164 * Looks like only during compiling the pads are illegal.
2167 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2169 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2174 SV * const sv = newSV(0);
2176 /* FIXME - is this making unwarranted assumptions about the
2177 UTF-8 cleanliness of the dump file handle? */
2180 gv_fullname3(sv, cGVOPo_gv, NULL);
2181 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2185 PerlIO_printf(Perl_debug_log, "(NULL)");
2191 /* print the lexical's name */
2192 CV * const cv = deb_curcv(cxstack_ix);
2195 PADLIST * const padlist = CvPADLIST(cv);
2196 PAD * const comppad = *PadlistARRAY(padlist);
2197 sv = *av_fetch(comppad, o->op_targ, FALSE);
2201 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2203 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2209 PerlIO_printf(Perl_debug_log, "\n");
2214 S_deb_curcv(pTHX_ const I32 ix)
2217 const PERL_CONTEXT * const cx = &cxstack[ix];
2218 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2219 return cx->blk_sub.cv;
2220 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2221 return cx->blk_eval.cv;
2222 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2227 return deb_curcv(ix - 1);
2231 Perl_watch(pTHX_ char **addr)
2235 PERL_ARGS_ASSERT_WATCH;
2237 PL_watchaddr = addr;
2239 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2240 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2244 S_debprof(pTHX_ const OP *o)
2248 PERL_ARGS_ASSERT_DEBPROF;
2250 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2252 if (!PL_profiledata)
2253 Newxz(PL_profiledata, MAXO, U32);
2254 ++PL_profiledata[o->op_type];
2258 Perl_debprofdump(pTHX)
2262 if (!PL_profiledata)
2264 for (i = 0; i < MAXO; i++) {
2265 if (PL_profiledata[i])
2266 PerlIO_printf(Perl_debug_log,
2267 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2274 * XML variants of most of the above routines
2278 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2282 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2284 PerlIO_printf(file, "\n ");
2285 va_start(args, pat);
2286 xmldump_vindent(level, file, pat, &args);
2292 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2295 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2296 va_start(args, pat);
2297 xmldump_vindent(level, file, pat, &args);
2302 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2304 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2306 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2307 PerlIO_vprintf(file, pat, *args);
2311 Perl_xmldump_all(pTHX)
2313 xmldump_all_perl(FALSE);
2317 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2319 PerlIO_setlinebuf(PL_xmlfp);
2321 op_xmldump(PL_main_root);
2322 /* someday we might call this, when it outputs XML: */
2323 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2324 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2325 PerlIO_close(PL_xmlfp);
2330 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2332 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2333 xmldump_packsubs_perl(stash, FALSE);
2337 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2342 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2344 if (!HvARRAY(stash))
2346 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2347 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2348 GV *gv = MUTABLE_GV(HeVAL(entry));
2350 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2353 xmldump_sub_perl(gv, justperl);
2356 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2357 && (hv = GvHV(gv)) && hv != PL_defstash)
2358 xmldump_packsubs_perl(hv, justperl); /* nested package */
2364 Perl_xmldump_sub(pTHX_ const GV *gv)
2366 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2367 xmldump_sub_perl(gv, FALSE);
2371 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2375 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2377 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2380 sv = sv_newmortal();
2381 gv_fullname3(sv, gv, NULL);
2382 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2383 if (CvXSUB(GvCV(gv)))
2384 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2385 PTR2UV(CvXSUB(GvCV(gv))),
2386 (int)CvXSUBANY(GvCV(gv)).any_i32);
2387 else if (CvROOT(GvCV(gv)))
2388 op_xmldump(CvROOT(GvCV(gv)));
2390 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2394 Perl_xmldump_form(pTHX_ const GV *gv)
2396 SV * const sv = sv_newmortal();
2398 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2400 gv_fullname3(sv, gv, NULL);
2401 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2402 if (CvROOT(GvFORM(gv)))
2403 op_xmldump(CvROOT(GvFORM(gv)));
2405 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2409 Perl_xmldump_eval(pTHX)
2411 op_xmldump(PL_eval_root);
2415 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2417 PERL_ARGS_ASSERT_SV_CATXMLSV;
2418 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2422 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2424 PERL_ARGS_ASSERT_SV_CATXMLPV;
2425 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2429 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2432 const char * const e = pv + len;
2433 const char * const start = pv;
2437 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2440 dsvcur = SvCUR(dsv); /* in case we have to restart */
2445 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2447 SvCUR(dsv) = dsvcur;
2512 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2515 sv_catpvs(dsv, "<");
2518 sv_catpvs(dsv, ">");
2521 sv_catpvs(dsv, "&");
2524 sv_catpvs(dsv, """);
2528 if (c < 32 || c > 127) {
2529 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2532 const char string = (char) c;
2533 sv_catpvn(dsv, &string, 1);
2537 if ((c >= 0xD800 && c <= 0xDB7F) ||
2538 (c >= 0xDC00 && c <= 0xDFFF) ||
2539 (c >= 0xFFF0 && c <= 0xFFFF) ||
2541 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2543 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2556 Perl_sv_xmlpeek(pTHX_ SV *sv)
2558 SV * const t = sv_newmortal();
2562 PERL_ARGS_ASSERT_SV_XMLPEEK;
2568 sv_catpv(t, "VOID=\"\"");
2571 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2572 sv_catpv(t, "WILD=\"\"");
2575 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2576 if (sv == &PL_sv_undef) {
2577 sv_catpv(t, "SV_UNDEF=\"1\"");
2578 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2579 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2583 else if (sv == &PL_sv_no) {
2584 sv_catpv(t, "SV_NO=\"1\"");
2585 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2586 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2587 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2588 SVp_POK|SVp_NOK)) &&
2593 else if (sv == &PL_sv_yes) {
2594 sv_catpv(t, "SV_YES=\"1\"");
2595 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2596 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2597 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2598 SVp_POK|SVp_NOK)) &&
2600 SvPVX(sv) && *SvPVX(sv) == '1' &&
2605 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2606 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2607 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2611 sv_catpv(t, " XXX=\"\" ");
2613 else if (SvREFCNT(sv) == 0) {
2614 sv_catpv(t, " refcnt=\"0\"");
2617 else if (DEBUG_R_TEST_) {
2620 /* is this SV on the tmps stack? */
2621 for (ix=PL_tmps_ix; ix>=0; ix--) {
2622 if (PL_tmps_stack[ix] == sv) {
2627 if (SvREFCNT(sv) > 1)
2628 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2631 sv_catpv(t, " DRT=\"<T>\"");
2635 sv_catpv(t, " ROK=\"\"");
2637 switch (SvTYPE(sv)) {
2639 sv_catpv(t, " FREED=\"1\"");
2643 sv_catpv(t, " UNDEF=\"1\"");
2646 sv_catpv(t, " IV=\"");
2649 sv_catpv(t, " NV=\"");
2652 sv_catpv(t, " PV=\"");
2655 sv_catpv(t, " PVIV=\"");
2658 sv_catpv(t, " PVNV=\"");
2661 sv_catpv(t, " PVMG=\"");
2664 sv_catpv(t, " PVLV=\"");
2667 sv_catpv(t, " AV=\"");
2670 sv_catpv(t, " HV=\"");
2674 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2676 sv_catpv(t, " CV=\"()\"");
2679 sv_catpv(t, " GV=\"");
2682 sv_catpv(t, " BIND=\"");
2685 sv_catpv(t, " REGEXP=\"");
2688 sv_catpv(t, " FM=\"");
2691 sv_catpv(t, " IO=\"");
2700 else if (SvNOKp(sv)) {
2701 STORE_NUMERIC_LOCAL_SET_STANDARD();
2702 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2703 RESTORE_NUMERIC_LOCAL();
2705 else if (SvIOKp(sv)) {
2707 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2709 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2718 return SvPV(t, n_a);
2722 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2724 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2727 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2730 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2733 REGEXP *const r = PM_GETRE(pm);
2734 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2735 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2736 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2738 SvREFCNT_dec(tmpsv);
2739 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2740 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2743 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2744 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2745 SV * const tmpsv = pm_description(pm);
2746 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2747 SvREFCNT_dec(tmpsv);
2751 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2752 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2753 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2754 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2755 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2756 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2759 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2763 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2765 do_pmop_xmldump(0, PL_xmlfp, pm);
2769 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2774 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2778 seq = sequence_num(o);
2779 Perl_xmldump_indent(aTHX_ level, file,
2780 "<op_%s seq=\"%"UVuf" -> ",
2785 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2786 sequence_num(o->op_next));
2788 PerlIO_printf(file, "DONE\"");
2791 if (o->op_type == OP_NULL)
2793 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2794 if (o->op_targ == OP_NEXTSTATE)
2797 PerlIO_printf(file, " line=\"%"UVuf"\"",
2798 (UV)CopLINE(cCOPo));
2799 if (CopSTASHPV(cCOPo))
2800 PerlIO_printf(file, " package=\"%s\"",
2802 if (CopLABEL(cCOPo))
2803 PerlIO_printf(file, " label=\"%s\"",
2808 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2811 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2814 SV * const tmpsv = newSVpvs("");
2815 switch (o->op_flags & OPf_WANT) {
2817 sv_catpv(tmpsv, ",VOID");
2819 case OPf_WANT_SCALAR:
2820 sv_catpv(tmpsv, ",SCALAR");
2823 sv_catpv(tmpsv, ",LIST");
2826 sv_catpv(tmpsv, ",UNKNOWN");
2829 if (o->op_flags & OPf_KIDS)
2830 sv_catpv(tmpsv, ",KIDS");
2831 if (o->op_flags & OPf_PARENS)
2832 sv_catpv(tmpsv, ",PARENS");
2833 if (o->op_flags & OPf_STACKED)
2834 sv_catpv(tmpsv, ",STACKED");
2835 if (o->op_flags & OPf_REF)
2836 sv_catpv(tmpsv, ",REF");
2837 if (o->op_flags & OPf_MOD)
2838 sv_catpv(tmpsv, ",MOD");
2839 if (o->op_flags & OPf_SPECIAL)
2840 sv_catpv(tmpsv, ",SPECIAL");
2841 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2842 SvREFCNT_dec(tmpsv);
2844 if (o->op_private) {
2845 SV * const tmpsv = newSVpvs("");
2846 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2847 if (o->op_private & OPpTARGET_MY)
2848 sv_catpv(tmpsv, ",TARGET_MY");
2850 else if (o->op_type == OP_LEAVESUB ||
2851 o->op_type == OP_LEAVE ||
2852 o->op_type == OP_LEAVESUBLV ||
2853 o->op_type == OP_LEAVEWRITE) {
2854 if (o->op_private & OPpREFCOUNTED)
2855 sv_catpv(tmpsv, ",REFCOUNTED");
2857 else if (o->op_type == OP_AASSIGN) {
2858 if (o->op_private & OPpASSIGN_COMMON)
2859 sv_catpv(tmpsv, ",COMMON");
2861 else if (o->op_type == OP_SASSIGN) {
2862 if (o->op_private & OPpASSIGN_BACKWARDS)
2863 sv_catpv(tmpsv, ",BACKWARDS");
2865 else if (o->op_type == OP_TRANS) {
2866 if (o->op_private & OPpTRANS_SQUASH)
2867 sv_catpv(tmpsv, ",SQUASH");
2868 if (o->op_private & OPpTRANS_DELETE)
2869 sv_catpv(tmpsv, ",DELETE");
2870 if (o->op_private & OPpTRANS_COMPLEMENT)
2871 sv_catpv(tmpsv, ",COMPLEMENT");
2872 if (o->op_private & OPpTRANS_IDENTICAL)
2873 sv_catpv(tmpsv, ",IDENTICAL");
2874 if (o->op_private & OPpTRANS_GROWS)
2875 sv_catpv(tmpsv, ",GROWS");
2877 else if (o->op_type == OP_REPEAT) {
2878 if (o->op_private & OPpREPEAT_DOLIST)
2879 sv_catpv(tmpsv, ",DOLIST");
2881 else if (o->op_type == OP_ENTERSUB ||
2882 o->op_type == OP_RV2SV ||
2883 o->op_type == OP_GVSV ||
2884 o->op_type == OP_RV2AV ||
2885 o->op_type == OP_RV2HV ||
2886 o->op_type == OP_RV2GV ||
2887 o->op_type == OP_AELEM ||
2888 o->op_type == OP_HELEM )
2890 if (o->op_type == OP_ENTERSUB) {
2891 if (o->op_private & OPpENTERSUB_AMPER)
2892 sv_catpv(tmpsv, ",AMPER");
2893 if (o->op_private & OPpENTERSUB_DB)
2894 sv_catpv(tmpsv, ",DB");
2895 if (o->op_private & OPpENTERSUB_HASTARG)
2896 sv_catpv(tmpsv, ",HASTARG");
2897 if (o->op_private & OPpENTERSUB_NOPAREN)
2898 sv_catpv(tmpsv, ",NOPAREN");
2899 if (o->op_private & OPpENTERSUB_INARGS)
2900 sv_catpv(tmpsv, ",INARGS");
2903 switch (o->op_private & OPpDEREF) {
2905 sv_catpv(tmpsv, ",SV");
2908 sv_catpv(tmpsv, ",AV");
2911 sv_catpv(tmpsv, ",HV");
2914 if (o->op_private & OPpMAYBE_LVSUB)
2915 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2917 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2918 if (o->op_private & OPpLVAL_DEFER)
2919 sv_catpv(tmpsv, ",LVAL_DEFER");
2922 if (o->op_private & HINT_STRICT_REFS)
2923 sv_catpv(tmpsv, ",STRICT_REFS");
2924 if (o->op_private & OPpOUR_INTRO)
2925 sv_catpv(tmpsv, ",OUR_INTRO");
2928 else if (o->op_type == OP_CONST) {
2929 if (o->op_private & OPpCONST_BARE)
2930 sv_catpv(tmpsv, ",BARE");
2931 if (o->op_private & OPpCONST_STRICT)
2932 sv_catpv(tmpsv, ",STRICT");
2933 if (o->op_private & OPpCONST_ENTERED)
2934 sv_catpv(tmpsv, ",ENTERED");
2935 if (o->op_private & OPpCONST_FOLDED)
2936 sv_catpv(tmpsv, ",FOLDED");
2938 else if (o->op_type == OP_FLIP) {
2939 if (o->op_private & OPpFLIP_LINENUM)
2940 sv_catpv(tmpsv, ",LINENUM");
2942 else if (o->op_type == OP_FLOP) {
2943 if (o->op_private & OPpFLIP_LINENUM)
2944 sv_catpv(tmpsv, ",LINENUM");
2946 else if (o->op_type == OP_RV2CV) {
2947 if (o->op_private & OPpLVAL_INTRO)
2948 sv_catpv(tmpsv, ",INTRO");
2950 else if (o->op_type == OP_GV) {
2951 if (o->op_private & OPpEARLY_CV)
2952 sv_catpv(tmpsv, ",EARLY_CV");
2954 else if (o->op_type == OP_LIST) {
2955 if (o->op_private & OPpLIST_GUESSED)
2956 sv_catpv(tmpsv, ",GUESSED");
2958 else if (o->op_type == OP_DELETE) {
2959 if (o->op_private & OPpSLICE)
2960 sv_catpv(tmpsv, ",SLICE");
2962 else if (o->op_type == OP_EXISTS) {
2963 if (o->op_private & OPpEXISTS_SUB)
2964 sv_catpv(tmpsv, ",EXISTS_SUB");
2966 else if (o->op_type == OP_SORT) {
2967 if (o->op_private & OPpSORT_NUMERIC)
2968 sv_catpv(tmpsv, ",NUMERIC");
2969 if (o->op_private & OPpSORT_INTEGER)
2970 sv_catpv(tmpsv, ",INTEGER");
2971 if (o->op_private & OPpSORT_REVERSE)
2972 sv_catpv(tmpsv, ",REVERSE");
2974 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2975 if (o->op_private & OPpOPEN_IN_RAW)
2976 sv_catpv(tmpsv, ",IN_RAW");
2977 if (o->op_private & OPpOPEN_IN_CRLF)
2978 sv_catpv(tmpsv, ",IN_CRLF");
2979 if (o->op_private & OPpOPEN_OUT_RAW)
2980 sv_catpv(tmpsv, ",OUT_RAW");
2981 if (o->op_private & OPpOPEN_OUT_CRLF)
2982 sv_catpv(tmpsv, ",OUT_CRLF");
2984 else if (o->op_type == OP_EXIT) {
2985 if (o->op_private & OPpEXIT_VMSISH)
2986 sv_catpv(tmpsv, ",EXIT_VMSISH");
2987 if (o->op_private & OPpHUSH_VMSISH)
2988 sv_catpv(tmpsv, ",HUSH_VMSISH");
2990 else if (o->op_type == OP_DIE) {
2991 if (o->op_private & OPpHUSH_VMSISH)
2992 sv_catpv(tmpsv, ",HUSH_VMSISH");
2994 else if (PL_check[o->op_type] != Perl_ck_ftst) {
2995 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2996 sv_catpv(tmpsv, ",FT_ACCESS");
2997 if (o->op_private & OPpFT_STACKED)
2998 sv_catpv(tmpsv, ",FT_STACKED");
3000 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
3001 sv_catpv(tmpsv, ",INTRO");
3003 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
3004 SvREFCNT_dec(tmpsv);
3007 switch (o->op_type) {
3009 if (o->op_flags & OPf_SPECIAL) {
3015 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3017 if (cSVOPo->op_sv) {
3018 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3019 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3025 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3026 s = SvPV(tmpsv1,len);
3027 sv_catxmlpvn(tmpsv2, s, len, 1);
3028 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3032 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3037 case OP_METHOD_NAMED:
3038 #ifndef USE_ITHREADS
3039 /* with ITHREADS, consts are stored in the pad, and the right pad
3040 * may not be active here, so skip */
3041 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3047 PerlIO_printf(file, ">\n");
3049 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3054 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3055 (UV)CopLINE(cCOPo));
3056 if (CopSTASHPV(cCOPo))
3057 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3059 if (CopLABEL(cCOPo))
3060 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3064 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3065 if (cLOOPo->op_redoop)
3066 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3068 PerlIO_printf(file, "DONE\"");
3069 S_xmldump_attr(aTHX_ level, file, "next=\"");
3070 if (cLOOPo->op_nextop)
3071 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3073 PerlIO_printf(file, "DONE\"");
3074 S_xmldump_attr(aTHX_ level, file, "last=\"");
3075 if (cLOOPo->op_lastop)
3076 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3078 PerlIO_printf(file, "DONE\"");
3086 S_xmldump_attr(aTHX_ level, file, "other=\"");
3087 if (cLOGOPo->op_other)
3088 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3090 PerlIO_printf(file, "DONE\"");
3098 if (o->op_private & OPpREFCOUNTED)
3099 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3105 if (PL_madskills && o->op_madprop) {
3106 char prevkey = '\0';
3107 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3108 const MADPROP* mp = o->op_madprop;
3112 PerlIO_printf(file, ">\n");
3114 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3117 char tmp = mp->mad_key;
3118 sv_setpvs(tmpsv,"\"");
3120 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3121 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3122 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3125 sv_catpv(tmpsv, "\"");
3126 switch (mp->mad_type) {
3128 sv_catpv(tmpsv, "NULL");
3129 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3132 sv_catpv(tmpsv, " val=\"");
3133 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3134 sv_catpv(tmpsv, "\"");
3135 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3138 sv_catpv(tmpsv, " val=\"");
3139 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3140 sv_catpv(tmpsv, "\"");
3141 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3144 if ((OP*)mp->mad_val) {
3145 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3146 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3147 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3151 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3157 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3159 SvREFCNT_dec(tmpsv);
3162 switch (o->op_type) {
3169 PerlIO_printf(file, ">\n");
3171 do_pmop_xmldump(level, file, cPMOPo);
3177 if (o->op_flags & OPf_KIDS) {
3181 PerlIO_printf(file, ">\n");
3183 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3184 do_op_xmldump(level, file, kid);
3188 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3190 PerlIO_printf(file, " />\n");
3194 Perl_op_xmldump(pTHX_ const OP *o)
3196 PERL_ARGS_ASSERT_OP_XMLDUMP;
3198 do_op_xmldump(0, PL_xmlfp, o);
3204 * c-indentation-style: bsd
3206 * indent-tabs-mode: nil
3209 * ex: set ts=8 sts=4 sw=4 et: