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_BARE, ",BARE"}
751 const struct flag_to_name op_sort_names[] = {
752 {OPpSORT_NUMERIC, ",NUMERIC"},
753 {OPpSORT_INTEGER, ",INTEGER"},
754 {OPpSORT_REVERSE, ",REVERSE"},
755 {OPpSORT_INPLACE, ",INPLACE"},
756 {OPpSORT_DESCEND, ",DESCEND"},
757 {OPpSORT_QSORT, ",QSORT"},
758 {OPpSORT_STABLE, ",STABLE"}
761 const struct flag_to_name op_open_names[] = {
762 {OPpOPEN_IN_RAW, ",IN_RAW"},
763 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
764 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
765 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
768 const struct flag_to_name op_exit_names[] = {
769 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
770 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
773 #define OP_PRIVATE_ONCE(op, flag, name) \
774 const struct flag_to_name CAT2(op, _names)[] = { \
778 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
779 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
780 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
781 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
782 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
783 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
784 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
785 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
786 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
787 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
788 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
789 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
791 struct op_private_by_op {
794 const struct flag_to_name *start;
797 const struct op_private_by_op op_private_names[] = {
798 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
799 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
800 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
801 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
802 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
803 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
804 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
805 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
806 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
807 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
808 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
809 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
810 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
811 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
812 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
813 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
814 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
815 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
816 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
817 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
818 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
822 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
823 const struct op_private_by_op *start = op_private_names;
824 const struct op_private_by_op *const end
825 = op_private_names + C_ARRAY_LENGTH(op_private_names);
827 /* This is a linear search, but no worse than the code that it replaced.
828 It's debugging code - size is more important than speed. */
830 if (optype == start->op_type) {
831 S_append_flags(aTHX_ tmpsv, op_private, start->start,
832 start->start + start->len);
835 } while (++start < end);
840 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
844 const OPCODE optype = o->op_type;
846 PERL_ARGS_ASSERT_DO_OP_DUMP;
848 Perl_dump_indent(aTHX_ level, file, "{\n");
850 seq = sequence_num(o);
852 PerlIO_printf(file, "%-4"UVuf, seq);
854 PerlIO_printf(file, "????");
856 "%*sTYPE = %s ===> ",
857 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
860 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
861 sequence_num(o->op_next));
863 PerlIO_printf(file, "NULL\n");
865 if (optype == OP_NULL) {
866 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
867 if (o->op_targ == OP_NEXTSTATE) {
869 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
871 if (CopSTASHPV(cCOPo))
872 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
875 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
880 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
883 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
885 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
886 SV * const tmpsv = newSVpvs("");
887 switch (o->op_flags & OPf_WANT) {
889 sv_catpv(tmpsv, ",VOID");
891 case OPf_WANT_SCALAR:
892 sv_catpv(tmpsv, ",SCALAR");
895 sv_catpv(tmpsv, ",LIST");
898 sv_catpv(tmpsv, ",UNKNOWN");
901 append_flags(tmpsv, o->op_flags, op_flags_names);
903 sv_catpv(tmpsv, ",LATEFREE");
905 sv_catpv(tmpsv, ",LATEFREED");
907 sv_catpv(tmpsv, ",ATTACHED");
908 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
912 SV * const tmpsv = newSVpvs("");
913 if (PL_opargs[optype] & OA_TARGLEX) {
914 if (o->op_private & OPpTARGET_MY)
915 sv_catpv(tmpsv, ",TARGET_MY");
917 else if (optype == OP_ENTERSUB ||
918 optype == OP_RV2SV ||
920 optype == OP_RV2AV ||
921 optype == OP_RV2HV ||
922 optype == OP_RV2GV ||
923 optype == OP_AELEM ||
926 if (optype == OP_ENTERSUB) {
927 append_flags(tmpsv, o->op_private, op_entersub_names);
930 switch (o->op_private & OPpDEREF) {
932 sv_catpv(tmpsv, ",SV");
935 sv_catpv(tmpsv, ",AV");
938 sv_catpv(tmpsv, ",HV");
941 if (o->op_private & OPpMAYBE_LVSUB)
942 sv_catpv(tmpsv, ",MAYBE_LVSUB");
945 if (optype == OP_AELEM || optype == OP_HELEM) {
946 if (o->op_private & OPpLVAL_DEFER)
947 sv_catpv(tmpsv, ",LVAL_DEFER");
950 if (o->op_private & HINT_STRICT_REFS)
951 sv_catpv(tmpsv, ",STRICT_REFS");
952 if (o->op_private & OPpOUR_INTRO)
953 sv_catpv(tmpsv, ",OUR_INTRO");
956 else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
958 else if (PL_check[optype] != Perl_ck_ftst) {
959 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
960 sv_catpv(tmpsv, ",FT_ACCESS");
961 if (o->op_private & OPpFT_STACKED)
962 sv_catpv(tmpsv, ",FT_STACKED");
964 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
965 sv_catpv(tmpsv, ",INTRO");
967 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
972 if (PL_madskills && o->op_madprop) {
973 SV * const tmpsv = newSVpvs("");
974 MADPROP* mp = o->op_madprop;
975 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
978 const char tmp = mp->mad_key;
979 sv_setpvs(tmpsv,"'");
981 sv_catpvn(tmpsv, &tmp, 1);
982 sv_catpv(tmpsv, "'=");
983 switch (mp->mad_type) {
985 sv_catpv(tmpsv, "NULL");
986 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
989 sv_catpv(tmpsv, "<");
990 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
991 sv_catpv(tmpsv, ">");
992 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
995 if ((OP*)mp->mad_val) {
996 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
997 do_op_dump(level, file, (OP*)mp->mad_val);
1001 sv_catpv(tmpsv, "(UNK)");
1002 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1008 Perl_dump_indent(aTHX_ level, file, "}\n");
1010 SvREFCNT_dec(tmpsv);
1019 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1021 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1022 if (cSVOPo->op_sv) {
1023 SV * const tmpsv = newSV(0);
1027 /* FIXME - is this making unwarranted assumptions about the
1028 UTF-8 cleanliness of the dump file handle? */
1031 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1032 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1033 SvPV_nolen_const(tmpsv));
1037 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1043 case OP_METHOD_NAMED:
1044 #ifndef USE_ITHREADS
1045 /* with ITHREADS, consts are stored in the pad, and the right pad
1046 * may not be active here, so skip */
1047 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1053 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1054 (UV)CopLINE(cCOPo));
1055 if (CopSTASHPV(cCOPo))
1056 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1058 if (CopLABEL(cCOPo))
1059 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1063 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1064 if (cLOOPo->op_redoop)
1065 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1067 PerlIO_printf(file, "DONE\n");
1068 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1069 if (cLOOPo->op_nextop)
1070 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1072 PerlIO_printf(file, "DONE\n");
1073 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1074 if (cLOOPo->op_lastop)
1075 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1077 PerlIO_printf(file, "DONE\n");
1085 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1086 if (cLOGOPo->op_other)
1087 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1089 PerlIO_printf(file, "DONE\n");
1095 do_pmop_dump(level, file, cPMOPo);
1103 if (o->op_private & OPpREFCOUNTED)
1104 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1109 if (o->op_flags & OPf_KIDS) {
1111 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1112 do_op_dump(level, file, kid);
1114 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1118 Perl_op_dump(pTHX_ const OP *o)
1120 PERL_ARGS_ASSERT_OP_DUMP;
1121 do_op_dump(0, Perl_debug_log, o);
1125 Perl_gv_dump(pTHX_ GV *gv)
1129 PERL_ARGS_ASSERT_GV_DUMP;
1132 PerlIO_printf(Perl_debug_log, "{}\n");
1135 sv = sv_newmortal();
1136 PerlIO_printf(Perl_debug_log, "{\n");
1137 gv_fullname3(sv, gv, NULL);
1138 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1139 if (gv != GvEGV(gv)) {
1140 gv_efullname3(sv, GvEGV(gv), NULL);
1141 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1143 PerlIO_putc(Perl_debug_log, '\n');
1144 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1148 /* map magic types to the symbolic names
1149 * (with the PERL_MAGIC_ prefixed stripped)
1152 static const struct { const char type; const char *name; } magic_names[] = {
1153 #include "mg_names.c"
1154 /* this null string terminates the list */
1159 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1161 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1163 for (; mg; mg = mg->mg_moremagic) {
1164 Perl_dump_indent(aTHX_ level, file,
1165 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1166 if (mg->mg_virtual) {
1167 const MGVTBL * const v = mg->mg_virtual;
1168 if (v >= PL_magic_vtables
1169 && v < PL_magic_vtables + magic_vtable_max) {
1170 const U32 i = v - PL_magic_vtables;
1171 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1174 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1177 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1180 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1184 const char *name = NULL;
1185 for (n = 0; magic_names[n].name; n++) {
1186 if (mg->mg_type == magic_names[n].type) {
1187 name = magic_names[n].name;
1192 Perl_dump_indent(aTHX_ level, file,
1193 " MG_TYPE = PERL_MAGIC_%s\n", name);
1195 Perl_dump_indent(aTHX_ level, file,
1196 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1200 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1201 if (mg->mg_type == PERL_MAGIC_envelem &&
1202 mg->mg_flags & MGf_TAINTEDDIR)
1203 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1204 if (mg->mg_type == PERL_MAGIC_regex_global &&
1205 mg->mg_flags & MGf_MINMATCH)
1206 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1207 if (mg->mg_flags & MGf_REFCOUNTED)
1208 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1209 if (mg->mg_flags & MGf_GSKIP)
1210 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1211 if (mg->mg_flags & MGf_COPY)
1212 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1213 if (mg->mg_flags & MGf_DUP)
1214 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1215 if (mg->mg_flags & MGf_LOCAL)
1216 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1219 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1220 PTR2UV(mg->mg_obj));
1221 if (mg->mg_type == PERL_MAGIC_qr) {
1222 REGEXP* const re = (REGEXP *)mg->mg_obj;
1223 SV * const dsv = sv_newmortal();
1224 const char * const s
1225 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1227 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1228 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1230 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1231 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1234 if (mg->mg_flags & MGf_REFCOUNTED)
1235 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1238 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1240 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1241 if (mg->mg_len >= 0) {
1242 if (mg->mg_type != PERL_MAGIC_utf8) {
1243 SV * const sv = newSVpvs("");
1244 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1248 else if (mg->mg_len == HEf_SVKEY) {
1249 PerlIO_puts(file, " => HEf_SVKEY\n");
1250 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1251 maxnest, dumpops, pvlim); /* MG is already +1 */
1254 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1259 " does not know how to handle this MG_LEN"
1261 PerlIO_putc(file, '\n');
1263 if (mg->mg_type == PERL_MAGIC_utf8) {
1264 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1267 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1268 Perl_dump_indent(aTHX_ level, file,
1269 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1272 (UV)cache[i * 2 + 1]);
1279 Perl_magic_dump(pTHX_ const MAGIC *mg)
1281 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1285 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1289 PERL_ARGS_ASSERT_DO_HV_DUMP;
1291 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1292 if (sv && (hvname = HvNAME_get(sv)))
1294 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1295 name which quite legally could contain insane things like tabs, newlines, nulls or
1296 other scary crap - this should produce sane results - except maybe for unicode package
1297 names - but we will wait for someone to file a bug on that - demerphq */
1298 SV * const tmpsv = newSVpvs("");
1299 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1302 PerlIO_putc(file, '\n');
1306 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1308 PERL_ARGS_ASSERT_DO_GV_DUMP;
1310 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1311 if (sv && GvNAME(sv))
1312 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1314 PerlIO_putc(file, '\n');
1318 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1320 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1322 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1323 if (sv && GvNAME(sv)) {
1325 PerlIO_printf(file, "\t\"");
1326 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1327 PerlIO_printf(file, "%s\" :: \"", hvname);
1328 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1331 PerlIO_putc(file, '\n');
1334 const struct flag_to_name first_sv_flags_names[] = {
1335 {SVs_TEMP, "TEMP,"},
1336 {SVs_OBJECT, "OBJECT,"},
1345 const struct flag_to_name second_sv_flags_names[] = {
1347 {SVf_FAKE, "FAKE,"},
1348 {SVf_READONLY, "READONLY,"},
1349 {SVf_BREAK, "BREAK,"},
1350 {SVf_AMAGIC, "OVERLOAD,"},
1356 const struct flag_to_name cv_flags_names[] = {
1357 {CVf_ANON, "ANON,"},
1358 {CVf_UNIQUE, "UNIQUE,"},
1359 {CVf_CLONE, "CLONE,"},
1360 {CVf_CLONED, "CLONED,"},
1361 {CVf_CONST, "CONST,"},
1362 {CVf_NODEBUG, "NODEBUG,"},
1363 {CVf_LVALUE, "LVALUE,"},
1364 {CVf_METHOD, "METHOD,"},
1365 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1366 {CVf_CVGV_RC, "CVGV_RC,"},
1367 {CVf_DYNFILE, "DYNFILE,"},
1368 {CVf_AUTOLOAD, "AUTOLOAD,"},
1369 {CVf_ISXSUB, "ISXSUB,"}
1372 const struct flag_to_name hv_flags_names[] = {
1373 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1374 {SVphv_LAZYDEL, "LAZYDEL,"},
1375 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1376 {SVphv_REHASH, "REHASH,"},
1377 {SVphv_CLONEABLE, "CLONEABLE,"}
1380 const struct flag_to_name gp_flags_names[] = {
1381 {GVf_INTRO, "INTRO,"},
1382 {GVf_MULTI, "MULTI,"},
1383 {GVf_ASSUMECV, "ASSUMECV,"},
1384 {GVf_IN_PAD, "IN_PAD,"}
1387 const struct flag_to_name gp_flags_imported_names[] = {
1388 {GVf_IMPORTED_SV, " SV"},
1389 {GVf_IMPORTED_AV, " AV"},
1390 {GVf_IMPORTED_HV, " HV"},
1391 {GVf_IMPORTED_CV, " CV"},
1394 const struct flag_to_name regexp_flags_names[] = {
1395 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1396 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1397 {RXf_PMf_FOLD, "PMf_FOLD,"},
1398 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1399 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1400 {RXf_ANCH_BOL, "ANCH_BOL,"},
1401 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1402 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1403 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1404 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1405 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1406 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1407 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1408 {RXf_CANY_SEEN, "CANY_SEEN,"},
1409 {RXf_NOSCAN, "NOSCAN,"},
1410 {RXf_CHECK_ALL, "CHECK_ALL,"},
1411 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1412 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1413 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1414 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1415 {RXf_SPLIT, "SPLIT,"},
1416 {RXf_COPY_DONE, "COPY_DONE,"},
1417 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1418 {RXf_TAINTED, "TAINTED,"},
1419 {RXf_START_ONLY, "START_ONLY,"},
1420 {RXf_SKIPWHITE, "SKIPWHITE,"},
1421 {RXf_WHITE, "WHITE,"},
1422 {RXf_NULL, "NULL,"},
1426 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1434 PERL_ARGS_ASSERT_DO_SV_DUMP;
1437 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1441 flags = SvFLAGS(sv);
1444 /* process general SV flags */
1446 d = Perl_newSVpvf(aTHX_
1447 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1448 PTR2UV(SvANY(sv)), PTR2UV(sv),
1449 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1450 (int)(PL_dumpindent*level), "");
1452 if (!((flags & SVpad_NAME) == SVpad_NAME
1453 && (type == SVt_PVMG || type == SVt_PVNV))) {
1454 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1455 sv_catpv(d, "PADSTALE,");
1457 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1458 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1459 sv_catpv(d, "PADTMP,");
1460 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1462 append_flags(d, flags, first_sv_flags_names);
1463 if (flags & SVf_ROK) {
1464 sv_catpv(d, "ROK,");
1465 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1467 append_flags(d, flags, second_sv_flags_names);
1468 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1469 if (SvPCS_IMPORTED(sv))
1470 sv_catpv(d, "PCS_IMPORTED,");
1472 sv_catpv(d, "SCREAM,");
1475 /* process type-specific SV flags */
1480 append_flags(d, CvFLAGS(sv), cv_flags_names);
1483 append_flags(d, flags, hv_flags_names);
1487 if (isGV_with_GP(sv)) {
1488 append_flags(d, GvFLAGS(sv), gp_flags_names);
1490 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1491 sv_catpv(d, "IMPORT");
1492 if (GvIMPORTED(sv) == GVf_IMPORTED)
1493 sv_catpv(d, "ALL,");
1496 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1503 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1504 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1507 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1508 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1509 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1510 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1513 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1518 /* SVphv_SHAREKEYS is also 0x20000000 */
1519 if ((type != SVt_PVHV) && SvUTF8(sv))
1520 sv_catpv(d, "UTF8");
1522 if (*(SvEND(d) - 1) == ',') {
1523 SvCUR_set(d, SvCUR(d) - 1);
1524 SvPVX(d)[SvCUR(d)] = '\0';
1529 /* dump initial SV details */
1531 #ifdef DEBUG_LEAKING_SCALARS
1532 Perl_dump_indent(aTHX_ level, file,
1533 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1534 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1536 sv->sv_debug_inpad ? "for" : "by",
1537 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1538 PTR2UV(sv->sv_debug_parent),
1542 Perl_dump_indent(aTHX_ level, file, "SV = ");
1546 if (type < SVt_LAST) {
1547 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1549 if (type == SVt_NULL) {
1554 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1559 /* Dump general SV fields */
1561 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1562 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1563 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1564 || (type == SVt_IV && !SvROK(sv))) {
1566 #ifdef PERL_OLD_COPY_ON_WRITE
1570 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1572 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1573 #ifdef PERL_OLD_COPY_ON_WRITE
1574 if (SvIsCOW_shared_hash(sv))
1575 PerlIO_printf(file, " (HASH)");
1576 else if (SvIsCOW_normal(sv))
1577 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1579 PerlIO_putc(file, '\n');
1582 if ((type == SVt_PVNV || type == SVt_PVMG)
1583 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1584 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1585 (UV) COP_SEQ_RANGE_LOW(sv));
1586 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1587 (UV) COP_SEQ_RANGE_HIGH(sv));
1588 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1589 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1590 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1591 || type == SVt_NV) {
1592 STORE_NUMERIC_LOCAL_SET_STANDARD();
1593 /* %Vg doesn't work? --jhi */
1594 #ifdef USE_LONG_DOUBLE
1595 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1597 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1599 RESTORE_NUMERIC_LOCAL();
1603 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1605 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1608 if (type < SVt_PV) {
1613 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1614 if (SvPVX_const(sv)) {
1617 SvOOK_offset(sv, delta);
1618 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1623 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1625 PerlIO_printf(file, "( %s . ) ",
1626 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1629 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1630 if (SvUTF8(sv)) /* the 6? \x{....} */
1631 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1632 PerlIO_printf(file, "\n");
1633 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1634 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1637 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1640 if (type >= SVt_PVMG) {
1641 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1642 HV * const ost = SvOURSTASH(sv);
1644 do_hv_dump(level, file, " OURSTASH", ost);
1647 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1650 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1652 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1653 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1654 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1655 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1659 /* Dump type-specific SV fields */
1663 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1664 if (AvARRAY(sv) != AvALLOC(sv)) {
1665 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1666 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1669 PerlIO_putc(file, '\n');
1670 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1671 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1672 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1674 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1675 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1676 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1677 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1678 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1680 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1681 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1683 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1685 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1690 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1691 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1692 /* Show distribution of HEs in the ARRAY */
1694 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1697 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1698 NV theoret, sum = 0;
1700 PerlIO_printf(file, " (");
1701 Zero(freq, FREQ_MAX + 1, int);
1702 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1705 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1707 if (count > FREQ_MAX)
1713 for (i = 0; i <= max; i++) {
1715 PerlIO_printf(file, "%d%s:%d", i,
1716 (i == FREQ_MAX) ? "+" : "",
1719 PerlIO_printf(file, ", ");
1722 PerlIO_putc(file, ')');
1723 /* The "quality" of a hash is defined as the total number of
1724 comparisons needed to access every element once, relative
1725 to the expected number needed for a random hash.
1727 The total number of comparisons is equal to the sum of
1728 the squares of the number of entries in each bucket.
1729 For a random hash of n keys into k buckets, the expected
1734 for (i = max; i > 0; i--) { /* Precision: count down. */
1735 sum += freq[i] * i * i;
1737 while ((keys = keys >> 1))
1739 theoret = HvUSEDKEYS(sv);
1740 theoret += theoret * (theoret-1)/pow2;
1741 PerlIO_putc(file, '\n');
1742 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1744 PerlIO_putc(file, '\n');
1745 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1746 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1747 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1748 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1749 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1751 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1752 if (mg && mg->mg_obj) {
1753 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1757 const char * const hvname = HvNAME_get(sv);
1759 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1763 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1764 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1765 if (HvAUX(sv)->xhv_name_count)
1766 Perl_dump_indent(aTHX_
1767 level, file, " NAMECOUNT = %"IVdf"\n",
1768 (IV)HvAUX(sv)->xhv_name_count
1770 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1771 const I32 count = HvAUX(sv)->xhv_name_count;
1773 SV * const names = newSVpvs_flags("", SVs_TEMP);
1774 /* The starting point is the first element if count is
1775 positive and the second element if count is negative. */
1776 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1777 + (count < 0 ? 1 : 0);
1778 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1779 + (count < 0 ? -count : count);
1780 while (hekp < endp) {
1782 sv_catpvs(names, ", \"");
1783 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1784 sv_catpvs(names, "\"");
1786 /* This should never happen. */
1787 sv_catpvs(names, ", (null)");
1791 Perl_dump_indent(aTHX_
1792 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1796 Perl_dump_indent(aTHX_
1797 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1801 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1803 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1807 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1808 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1809 (int)meta->mro_which->length,
1810 meta->mro_which->name,
1811 PTR2UV(meta->mro_which));
1812 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1813 (UV)meta->cache_gen);
1814 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1816 if (meta->mro_linear_all) {
1817 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1818 PTR2UV(meta->mro_linear_all));
1819 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1822 if (meta->mro_linear_current) {
1823 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1824 PTR2UV(meta->mro_linear_current));
1825 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1828 if (meta->mro_nextmethod) {
1829 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1830 PTR2UV(meta->mro_nextmethod));
1831 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1835 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1837 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1842 if (nest < maxnest) {
1843 HV * const hv = MUTABLE_HV(sv);
1848 int count = maxnest - nest;
1849 for (i=0; i <= HvMAX(hv); i++) {
1850 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1857 if (count-- <= 0) goto DONEHV;
1860 keysv = hv_iterkeysv(he);
1861 keypv = SvPV_const(keysv, len);
1864 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1866 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1867 if (HvEITER_get(hv) == he)
1868 PerlIO_printf(file, "[CURRENT] ");
1870 PerlIO_printf(file, "[REHASH] ");
1871 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1872 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1881 if (CvAUTOLOAD(sv)) {
1883 const char *const name = SvPV_const(sv, len);
1884 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1888 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1889 (int) CvPROTOLEN(sv), CvPROTO(sv));
1893 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1894 if (!CvISXSUB(sv)) {
1896 Perl_dump_indent(aTHX_ level, file,
1897 " START = 0x%"UVxf" ===> %"IVdf"\n",
1898 PTR2UV(CvSTART(sv)),
1899 (IV)sequence_num(CvSTART(sv)));
1901 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1902 PTR2UV(CvROOT(sv)));
1903 if (CvROOT(sv) && dumpops) {
1904 do_op_dump(level+1, file, CvROOT(sv));
1907 SV * const constant = cv_const_sv((const CV *)sv);
1909 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1912 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1914 PTR2UV(CvXSUBANY(sv).any_ptr));
1915 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1918 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1919 (IV)CvXSUBANY(sv).any_i32);
1922 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1923 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1924 if (type == SVt_PVCV)
1925 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1926 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1927 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1928 if (type == SVt_PVFM)
1929 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1930 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1931 if (nest < maxnest) {
1932 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1935 const CV * const outside = CvOUTSIDE(sv);
1936 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1939 : CvANON(outside) ? "ANON"
1940 : (outside == PL_main_cv) ? "MAIN"
1941 : CvUNIQUE(outside) ? "UNIQUE"
1942 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1944 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1945 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1950 if (type == SVt_PVLV) {
1951 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1952 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1953 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1954 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1955 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
1956 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1957 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1960 if (!isGV_with_GP(sv))
1962 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1963 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1964 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1965 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1968 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1969 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1970 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1971 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1972 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1973 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1974 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1975 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1976 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1977 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1978 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1979 do_gv_dump (level, file, " EGV", GvEGV(sv));
1982 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1983 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1984 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1985 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1986 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1987 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1988 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1990 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1991 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1992 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1994 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1995 PTR2UV(IoTOP_GV(sv)));
1996 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1997 maxnest, dumpops, pvlim);
1999 /* Source filters hide things that are not GVs in these three, so let's
2000 be careful out there. */
2002 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2003 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2004 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2006 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2007 PTR2UV(IoFMT_GV(sv)));
2008 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2009 maxnest, dumpops, pvlim);
2011 if (IoBOTTOM_NAME(sv))
2012 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2013 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2014 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2016 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2017 PTR2UV(IoBOTTOM_GV(sv)));
2018 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2019 maxnest, dumpops, pvlim);
2021 if (isPRINT(IoTYPE(sv)))
2022 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2024 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2025 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2029 struct regexp * const r = (struct regexp *)SvANY(sv);
2030 flags = RX_EXTFLAGS((REGEXP*)sv);
2032 append_flags(d, flags, regexp_flags_names);
2033 if (*(SvEND(d) - 1) == ',') {
2034 SvCUR_set(d, SvCUR(d) - 1);
2035 SvPVX(d)[SvCUR(d)] = '\0';
2037 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2038 (UV)flags, SvPVX_const(d));
2039 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2041 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2043 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2044 (UV)(r->lastparen));
2045 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2046 (UV)(r->lastcloseparen));
2047 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2049 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2050 (IV)(r->minlenret));
2051 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2053 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2054 (UV)(r->pre_prefix));
2055 Perl_dump_indent(aTHX_ level, file, " SEEN_EVALS = %"UVuf"\n",
2056 (UV)(r->seen_evals));
2057 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2060 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2062 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2064 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2065 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2067 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2068 PTR2UV(r->mother_re));
2069 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2070 PTR2UV(r->paren_names));
2071 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2072 PTR2UV(r->substrs));
2073 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2074 PTR2UV(r->pprivate));
2075 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2077 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2078 PTR2UV(r->qr_anoncv));
2079 #ifdef PERL_OLD_COPY_ON_WRITE
2080 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2081 PTR2UV(r->saved_copy));
2090 Perl_sv_dump(pTHX_ SV *sv)
2094 PERL_ARGS_ASSERT_SV_DUMP;
2097 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2099 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2103 Perl_runops_debug(pTHX)
2107 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2111 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2114 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2115 PerlIO_printf(Perl_debug_log,
2116 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2117 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2118 PTR2UV(*PL_watchaddr));
2119 if (DEBUG_s_TEST_) {
2120 if (DEBUG_v_TEST_) {
2121 PerlIO_printf(Perl_debug_log, "\n");
2129 if (DEBUG_t_TEST_) debop(PL_op);
2130 if (DEBUG_P_TEST_) debprof(PL_op);
2132 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2133 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2140 Perl_debop(pTHX_ const OP *o)
2144 PERL_ARGS_ASSERT_DEBOP;
2146 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2149 Perl_deb(aTHX_ "%s", OP_NAME(o));
2150 switch (o->op_type) {
2153 /* With ITHREADS, consts are stored in the pad, and the right pad
2154 * may not be active here, so check.
2155 * Looks like only during compiling the pads are illegal.
2158 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2160 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2165 SV * const sv = newSV(0);
2167 /* FIXME - is this making unwarranted assumptions about the
2168 UTF-8 cleanliness of the dump file handle? */
2171 gv_fullname3(sv, cGVOPo_gv, NULL);
2172 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2176 PerlIO_printf(Perl_debug_log, "(NULL)");
2182 /* print the lexical's name */
2183 CV * const cv = deb_curcv(cxstack_ix);
2186 AV * const padlist = CvPADLIST(cv);
2187 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2188 sv = *av_fetch(comppad, o->op_targ, FALSE);
2192 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2194 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2200 PerlIO_printf(Perl_debug_log, "\n");
2205 S_deb_curcv(pTHX_ const I32 ix)
2208 const PERL_CONTEXT * const cx = &cxstack[ix];
2209 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2210 return cx->blk_sub.cv;
2211 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2212 return cx->blk_eval.cv;
2213 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2218 return deb_curcv(ix - 1);
2222 Perl_watch(pTHX_ char **addr)
2226 PERL_ARGS_ASSERT_WATCH;
2228 PL_watchaddr = addr;
2230 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2231 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2235 S_debprof(pTHX_ const OP *o)
2239 PERL_ARGS_ASSERT_DEBPROF;
2241 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2243 if (!PL_profiledata)
2244 Newxz(PL_profiledata, MAXO, U32);
2245 ++PL_profiledata[o->op_type];
2249 Perl_debprofdump(pTHX)
2253 if (!PL_profiledata)
2255 for (i = 0; i < MAXO; i++) {
2256 if (PL_profiledata[i])
2257 PerlIO_printf(Perl_debug_log,
2258 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2265 * XML variants of most of the above routines
2269 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2273 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2275 PerlIO_printf(file, "\n ");
2276 va_start(args, pat);
2277 xmldump_vindent(level, file, pat, &args);
2283 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2286 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2287 va_start(args, pat);
2288 xmldump_vindent(level, file, pat, &args);
2293 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2295 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2297 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2298 PerlIO_vprintf(file, pat, *args);
2302 Perl_xmldump_all(pTHX)
2304 xmldump_all_perl(FALSE);
2308 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2310 PerlIO_setlinebuf(PL_xmlfp);
2312 op_xmldump(PL_main_root);
2313 /* someday we might call this, when it outputs XML: */
2314 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2315 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2316 PerlIO_close(PL_xmlfp);
2321 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2323 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2324 xmldump_packsubs_perl(stash, FALSE);
2328 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2333 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2335 if (!HvARRAY(stash))
2337 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2338 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2339 GV *gv = MUTABLE_GV(HeVAL(entry));
2341 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2344 xmldump_sub_perl(gv, justperl);
2347 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2348 && (hv = GvHV(gv)) && hv != PL_defstash)
2349 xmldump_packsubs_perl(hv, justperl); /* nested package */
2355 Perl_xmldump_sub(pTHX_ const GV *gv)
2357 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2358 xmldump_sub_perl(gv, FALSE);
2362 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2366 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2368 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2371 sv = sv_newmortal();
2372 gv_fullname3(sv, gv, NULL);
2373 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2374 if (CvXSUB(GvCV(gv)))
2375 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2376 PTR2UV(CvXSUB(GvCV(gv))),
2377 (int)CvXSUBANY(GvCV(gv)).any_i32);
2378 else if (CvROOT(GvCV(gv)))
2379 op_xmldump(CvROOT(GvCV(gv)));
2381 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2385 Perl_xmldump_form(pTHX_ const GV *gv)
2387 SV * const sv = sv_newmortal();
2389 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2391 gv_fullname3(sv, gv, NULL);
2392 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2393 if (CvROOT(GvFORM(gv)))
2394 op_xmldump(CvROOT(GvFORM(gv)));
2396 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2400 Perl_xmldump_eval(pTHX)
2402 op_xmldump(PL_eval_root);
2406 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2408 PERL_ARGS_ASSERT_SV_CATXMLSV;
2409 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2413 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2415 PERL_ARGS_ASSERT_SV_CATXMLPV;
2416 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2420 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2423 const char * const e = pv + len;
2424 const char * const start = pv;
2428 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2431 dsvcur = SvCUR(dsv); /* in case we have to restart */
2436 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2438 SvCUR(dsv) = dsvcur;
2503 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2506 sv_catpvs(dsv, "<");
2509 sv_catpvs(dsv, ">");
2512 sv_catpvs(dsv, "&");
2515 sv_catpvs(dsv, """);
2519 if (c < 32 || c > 127) {
2520 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2523 const char string = (char) c;
2524 sv_catpvn(dsv, &string, 1);
2528 if ((c >= 0xD800 && c <= 0xDB7F) ||
2529 (c >= 0xDC00 && c <= 0xDFFF) ||
2530 (c >= 0xFFF0 && c <= 0xFFFF) ||
2532 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2534 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2547 Perl_sv_xmlpeek(pTHX_ SV *sv)
2549 SV * const t = sv_newmortal();
2553 PERL_ARGS_ASSERT_SV_XMLPEEK;
2559 sv_catpv(t, "VOID=\"\"");
2562 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2563 sv_catpv(t, "WILD=\"\"");
2566 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2567 if (sv == &PL_sv_undef) {
2568 sv_catpv(t, "SV_UNDEF=\"1\"");
2569 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2570 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2574 else if (sv == &PL_sv_no) {
2575 sv_catpv(t, "SV_NO=\"1\"");
2576 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2577 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2578 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2579 SVp_POK|SVp_NOK)) &&
2584 else if (sv == &PL_sv_yes) {
2585 sv_catpv(t, "SV_YES=\"1\"");
2586 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2587 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2588 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2589 SVp_POK|SVp_NOK)) &&
2591 SvPVX(sv) && *SvPVX(sv) == '1' &&
2596 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2597 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2598 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2602 sv_catpv(t, " XXX=\"\" ");
2604 else if (SvREFCNT(sv) == 0) {
2605 sv_catpv(t, " refcnt=\"0\"");
2608 else if (DEBUG_R_TEST_) {
2611 /* is this SV on the tmps stack? */
2612 for (ix=PL_tmps_ix; ix>=0; ix--) {
2613 if (PL_tmps_stack[ix] == sv) {
2618 if (SvREFCNT(sv) > 1)
2619 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2622 sv_catpv(t, " DRT=\"<T>\"");
2626 sv_catpv(t, " ROK=\"\"");
2628 switch (SvTYPE(sv)) {
2630 sv_catpv(t, " FREED=\"1\"");
2634 sv_catpv(t, " UNDEF=\"1\"");
2637 sv_catpv(t, " IV=\"");
2640 sv_catpv(t, " NV=\"");
2643 sv_catpv(t, " PV=\"");
2646 sv_catpv(t, " PVIV=\"");
2649 sv_catpv(t, " PVNV=\"");
2652 sv_catpv(t, " PVMG=\"");
2655 sv_catpv(t, " PVLV=\"");
2658 sv_catpv(t, " AV=\"");
2661 sv_catpv(t, " HV=\"");
2665 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2667 sv_catpv(t, " CV=\"()\"");
2670 sv_catpv(t, " GV=\"");
2673 sv_catpv(t, " BIND=\"");
2676 sv_catpv(t, " REGEXP=\"");
2679 sv_catpv(t, " FM=\"");
2682 sv_catpv(t, " IO=\"");
2691 else if (SvNOKp(sv)) {
2692 STORE_NUMERIC_LOCAL_SET_STANDARD();
2693 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2694 RESTORE_NUMERIC_LOCAL();
2696 else if (SvIOKp(sv)) {
2698 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2700 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2709 return SvPV(t, n_a);
2713 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2715 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2718 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2721 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2724 REGEXP *const r = PM_GETRE(pm);
2725 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2726 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2727 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2729 SvREFCNT_dec(tmpsv);
2730 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2731 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2734 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2735 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2736 SV * const tmpsv = pm_description(pm);
2737 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2738 SvREFCNT_dec(tmpsv);
2742 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2743 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2744 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2745 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2746 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2747 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2750 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2754 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2756 do_pmop_xmldump(0, PL_xmlfp, pm);
2760 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2765 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2769 seq = sequence_num(o);
2770 Perl_xmldump_indent(aTHX_ level, file,
2771 "<op_%s seq=\"%"UVuf" -> ",
2776 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2777 sequence_num(o->op_next));
2779 PerlIO_printf(file, "DONE\"");
2782 if (o->op_type == OP_NULL)
2784 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2785 if (o->op_targ == OP_NEXTSTATE)
2788 PerlIO_printf(file, " line=\"%"UVuf"\"",
2789 (UV)CopLINE(cCOPo));
2790 if (CopSTASHPV(cCOPo))
2791 PerlIO_printf(file, " package=\"%s\"",
2793 if (CopLABEL(cCOPo))
2794 PerlIO_printf(file, " label=\"%s\"",
2799 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2802 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2805 SV * const tmpsv = newSVpvs("");
2806 switch (o->op_flags & OPf_WANT) {
2808 sv_catpv(tmpsv, ",VOID");
2810 case OPf_WANT_SCALAR:
2811 sv_catpv(tmpsv, ",SCALAR");
2814 sv_catpv(tmpsv, ",LIST");
2817 sv_catpv(tmpsv, ",UNKNOWN");
2820 if (o->op_flags & OPf_KIDS)
2821 sv_catpv(tmpsv, ",KIDS");
2822 if (o->op_flags & OPf_PARENS)
2823 sv_catpv(tmpsv, ",PARENS");
2824 if (o->op_flags & OPf_STACKED)
2825 sv_catpv(tmpsv, ",STACKED");
2826 if (o->op_flags & OPf_REF)
2827 sv_catpv(tmpsv, ",REF");
2828 if (o->op_flags & OPf_MOD)
2829 sv_catpv(tmpsv, ",MOD");
2830 if (o->op_flags & OPf_SPECIAL)
2831 sv_catpv(tmpsv, ",SPECIAL");
2832 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2833 SvREFCNT_dec(tmpsv);
2835 if (o->op_private) {
2836 SV * const tmpsv = newSVpvs("");
2837 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2838 if (o->op_private & OPpTARGET_MY)
2839 sv_catpv(tmpsv, ",TARGET_MY");
2841 else if (o->op_type == OP_LEAVESUB ||
2842 o->op_type == OP_LEAVE ||
2843 o->op_type == OP_LEAVESUBLV ||
2844 o->op_type == OP_LEAVEWRITE) {
2845 if (o->op_private & OPpREFCOUNTED)
2846 sv_catpv(tmpsv, ",REFCOUNTED");
2848 else if (o->op_type == OP_AASSIGN) {
2849 if (o->op_private & OPpASSIGN_COMMON)
2850 sv_catpv(tmpsv, ",COMMON");
2852 else if (o->op_type == OP_SASSIGN) {
2853 if (o->op_private & OPpASSIGN_BACKWARDS)
2854 sv_catpv(tmpsv, ",BACKWARDS");
2856 else if (o->op_type == OP_TRANS) {
2857 if (o->op_private & OPpTRANS_SQUASH)
2858 sv_catpv(tmpsv, ",SQUASH");
2859 if (o->op_private & OPpTRANS_DELETE)
2860 sv_catpv(tmpsv, ",DELETE");
2861 if (o->op_private & OPpTRANS_COMPLEMENT)
2862 sv_catpv(tmpsv, ",COMPLEMENT");
2863 if (o->op_private & OPpTRANS_IDENTICAL)
2864 sv_catpv(tmpsv, ",IDENTICAL");
2865 if (o->op_private & OPpTRANS_GROWS)
2866 sv_catpv(tmpsv, ",GROWS");
2868 else if (o->op_type == OP_REPEAT) {
2869 if (o->op_private & OPpREPEAT_DOLIST)
2870 sv_catpv(tmpsv, ",DOLIST");
2872 else if (o->op_type == OP_ENTERSUB ||
2873 o->op_type == OP_RV2SV ||
2874 o->op_type == OP_GVSV ||
2875 o->op_type == OP_RV2AV ||
2876 o->op_type == OP_RV2HV ||
2877 o->op_type == OP_RV2GV ||
2878 o->op_type == OP_AELEM ||
2879 o->op_type == OP_HELEM )
2881 if (o->op_type == OP_ENTERSUB) {
2882 if (o->op_private & OPpENTERSUB_AMPER)
2883 sv_catpv(tmpsv, ",AMPER");
2884 if (o->op_private & OPpENTERSUB_DB)
2885 sv_catpv(tmpsv, ",DB");
2886 if (o->op_private & OPpENTERSUB_HASTARG)
2887 sv_catpv(tmpsv, ",HASTARG");
2888 if (o->op_private & OPpENTERSUB_NOPAREN)
2889 sv_catpv(tmpsv, ",NOPAREN");
2890 if (o->op_private & OPpENTERSUB_INARGS)
2891 sv_catpv(tmpsv, ",INARGS");
2894 switch (o->op_private & OPpDEREF) {
2896 sv_catpv(tmpsv, ",SV");
2899 sv_catpv(tmpsv, ",AV");
2902 sv_catpv(tmpsv, ",HV");
2905 if (o->op_private & OPpMAYBE_LVSUB)
2906 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2908 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2909 if (o->op_private & OPpLVAL_DEFER)
2910 sv_catpv(tmpsv, ",LVAL_DEFER");
2913 if (o->op_private & HINT_STRICT_REFS)
2914 sv_catpv(tmpsv, ",STRICT_REFS");
2915 if (o->op_private & OPpOUR_INTRO)
2916 sv_catpv(tmpsv, ",OUR_INTRO");
2919 else if (o->op_type == OP_CONST) {
2920 if (o->op_private & OPpCONST_BARE)
2921 sv_catpv(tmpsv, ",BARE");
2922 if (o->op_private & OPpCONST_STRICT)
2923 sv_catpv(tmpsv, ",STRICT");
2924 if (o->op_private & OPpCONST_ENTERED)
2925 sv_catpv(tmpsv, ",ENTERED");
2927 else if (o->op_type == OP_FLIP) {
2928 if (o->op_private & OPpFLIP_LINENUM)
2929 sv_catpv(tmpsv, ",LINENUM");
2931 else if (o->op_type == OP_FLOP) {
2932 if (o->op_private & OPpFLIP_LINENUM)
2933 sv_catpv(tmpsv, ",LINENUM");
2935 else if (o->op_type == OP_RV2CV) {
2936 if (o->op_private & OPpLVAL_INTRO)
2937 sv_catpv(tmpsv, ",INTRO");
2939 else if (o->op_type == OP_GV) {
2940 if (o->op_private & OPpEARLY_CV)
2941 sv_catpv(tmpsv, ",EARLY_CV");
2943 else if (o->op_type == OP_LIST) {
2944 if (o->op_private & OPpLIST_GUESSED)
2945 sv_catpv(tmpsv, ",GUESSED");
2947 else if (o->op_type == OP_DELETE) {
2948 if (o->op_private & OPpSLICE)
2949 sv_catpv(tmpsv, ",SLICE");
2951 else if (o->op_type == OP_EXISTS) {
2952 if (o->op_private & OPpEXISTS_SUB)
2953 sv_catpv(tmpsv, ",EXISTS_SUB");
2955 else if (o->op_type == OP_SORT) {
2956 if (o->op_private & OPpSORT_NUMERIC)
2957 sv_catpv(tmpsv, ",NUMERIC");
2958 if (o->op_private & OPpSORT_INTEGER)
2959 sv_catpv(tmpsv, ",INTEGER");
2960 if (o->op_private & OPpSORT_REVERSE)
2961 sv_catpv(tmpsv, ",REVERSE");
2963 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2964 if (o->op_private & OPpOPEN_IN_RAW)
2965 sv_catpv(tmpsv, ",IN_RAW");
2966 if (o->op_private & OPpOPEN_IN_CRLF)
2967 sv_catpv(tmpsv, ",IN_CRLF");
2968 if (o->op_private & OPpOPEN_OUT_RAW)
2969 sv_catpv(tmpsv, ",OUT_RAW");
2970 if (o->op_private & OPpOPEN_OUT_CRLF)
2971 sv_catpv(tmpsv, ",OUT_CRLF");
2973 else if (o->op_type == OP_EXIT) {
2974 if (o->op_private & OPpEXIT_VMSISH)
2975 sv_catpv(tmpsv, ",EXIT_VMSISH");
2976 if (o->op_private & OPpHUSH_VMSISH)
2977 sv_catpv(tmpsv, ",HUSH_VMSISH");
2979 else if (o->op_type == OP_DIE) {
2980 if (o->op_private & OPpHUSH_VMSISH)
2981 sv_catpv(tmpsv, ",HUSH_VMSISH");
2983 else if (PL_check[o->op_type] != Perl_ck_ftst) {
2984 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2985 sv_catpv(tmpsv, ",FT_ACCESS");
2986 if (o->op_private & OPpFT_STACKED)
2987 sv_catpv(tmpsv, ",FT_STACKED");
2989 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2990 sv_catpv(tmpsv, ",INTRO");
2992 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2993 SvREFCNT_dec(tmpsv);
2996 switch (o->op_type) {
2998 if (o->op_flags & OPf_SPECIAL) {
3004 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3006 if (cSVOPo->op_sv) {
3007 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3008 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3014 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3015 s = SvPV(tmpsv1,len);
3016 sv_catxmlpvn(tmpsv2, s, len, 1);
3017 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3021 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3026 case OP_METHOD_NAMED:
3027 #ifndef USE_ITHREADS
3028 /* with ITHREADS, consts are stored in the pad, and the right pad
3029 * may not be active here, so skip */
3030 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3036 PerlIO_printf(file, ">\n");
3038 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3043 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3044 (UV)CopLINE(cCOPo));
3045 if (CopSTASHPV(cCOPo))
3046 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3048 if (CopLABEL(cCOPo))
3049 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3053 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3054 if (cLOOPo->op_redoop)
3055 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3057 PerlIO_printf(file, "DONE\"");
3058 S_xmldump_attr(aTHX_ level, file, "next=\"");
3059 if (cLOOPo->op_nextop)
3060 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3062 PerlIO_printf(file, "DONE\"");
3063 S_xmldump_attr(aTHX_ level, file, "last=\"");
3064 if (cLOOPo->op_lastop)
3065 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3067 PerlIO_printf(file, "DONE\"");
3075 S_xmldump_attr(aTHX_ level, file, "other=\"");
3076 if (cLOGOPo->op_other)
3077 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3079 PerlIO_printf(file, "DONE\"");
3087 if (o->op_private & OPpREFCOUNTED)
3088 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3094 if (PL_madskills && o->op_madprop) {
3095 char prevkey = '\0';
3096 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3097 const MADPROP* mp = o->op_madprop;
3101 PerlIO_printf(file, ">\n");
3103 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3106 char tmp = mp->mad_key;
3107 sv_setpvs(tmpsv,"\"");
3109 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3110 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3111 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3114 sv_catpv(tmpsv, "\"");
3115 switch (mp->mad_type) {
3117 sv_catpv(tmpsv, "NULL");
3118 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3121 sv_catpv(tmpsv, " val=\"");
3122 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3123 sv_catpv(tmpsv, "\"");
3124 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3127 sv_catpv(tmpsv, " val=\"");
3128 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3129 sv_catpv(tmpsv, "\"");
3130 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3133 if ((OP*)mp->mad_val) {
3134 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3135 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3136 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3140 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3146 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3148 SvREFCNT_dec(tmpsv);
3151 switch (o->op_type) {
3158 PerlIO_printf(file, ">\n");
3160 do_pmop_xmldump(level, file, cPMOPo);
3166 if (o->op_flags & OPf_KIDS) {
3170 PerlIO_printf(file, ">\n");
3172 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3173 do_op_xmldump(level, file, kid);
3177 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3179 PerlIO_printf(file, " />\n");
3183 Perl_op_xmldump(pTHX_ const OP *o)
3185 PERL_ARGS_ASSERT_OP_XMLDUMP;
3187 do_op_xmldump(0, PL_xmlfp, o);
3193 * c-indentation-style: bsd
3195 * indent-tabs-mode: nil
3198 * ex: set ts=8 sts=4 sw=4 et: