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((U8*)pv, &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_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
617 SV * const tmpsv = pm_description(pm);
618 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
622 Perl_dump_indent(aTHX_ level-1, file, "}\n");
625 const struct flag_to_name pmflags_flags_names[] = {
626 {PMf_CONST, ",CONST"},
628 {PMf_GLOBAL, ",GLOBAL"},
629 {PMf_CONTINUE, ",CONTINUE"},
630 {PMf_RETAINT, ",RETAINT"},
632 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
636 S_pm_description(pTHX_ const PMOP *pm)
638 SV * const desc = newSVpvs("");
639 const REGEXP * const regex = PM_GETRE(pm);
640 const U32 pmflags = pm->op_pmflags;
642 PERL_ARGS_ASSERT_PM_DESCRIPTION;
644 if (pmflags & PMf_ONCE)
645 sv_catpv(desc, ",ONCE");
647 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
648 sv_catpv(desc, ":USED");
650 if (pmflags & PMf_USED)
651 sv_catpv(desc, ":USED");
655 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
656 sv_catpv(desc, ",TAINTED");
657 if (RX_CHECK_SUBSTR(regex)) {
658 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
659 sv_catpv(desc, ",SCANFIRST");
660 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
661 sv_catpv(desc, ",ALL");
663 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
664 sv_catpv(desc, ",SKIPWHITE");
667 append_flags(desc, pmflags, pmflags_flags_names);
672 Perl_pmop_dump(pTHX_ PMOP *pm)
674 do_pmop_dump(0, Perl_debug_log, pm);
677 /* Return a unique integer to represent the address of op o.
678 * If it already exists in PL_op_sequence, just return it;
680 * *** Note that this isn't thread-safe */
683 S_sequence_num(pTHX_ const OP *o)
692 op = newSVuv(PTR2UV(o));
694 key = SvPV_const(op, len);
696 PL_op_sequence = newHV();
697 seq = hv_fetch(PL_op_sequence, key, len, 0);
700 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
704 const struct flag_to_name op_flags_names[] = {
706 {OPf_PARENS, ",PARENS"},
709 {OPf_STACKED, ",STACKED"},
710 {OPf_SPECIAL, ",SPECIAL"}
713 const struct flag_to_name op_trans_names[] = {
714 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
715 {OPpTRANS_TO_UTF, ",TO_UTF"},
716 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
717 {OPpTRANS_SQUASH, ",SQUASH"},
718 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
719 {OPpTRANS_GROWS, ",GROWS"},
720 {OPpTRANS_DELETE, ",DELETE"}
723 const struct flag_to_name op_entersub_names[] = {
724 {OPpENTERSUB_DB, ",DB"},
725 {OPpENTERSUB_HASTARG, ",HASTARG"},
726 {OPpENTERSUB_AMPER, ",AMPER"},
727 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
728 {OPpENTERSUB_INARGS, ",INARGS"}
731 const struct flag_to_name op_const_names[] = {
732 {OPpCONST_NOVER, ",NOVER"},
733 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
734 {OPpCONST_STRICT, ",STRICT"},
735 {OPpCONST_ENTERED, ",ENTERED"},
736 {OPpCONST_BARE, ",BARE"},
737 {OPpCONST_WARNING, ",WARNING"}
740 const struct flag_to_name op_sort_names[] = {
741 {OPpSORT_NUMERIC, ",NUMERIC"},
742 {OPpSORT_INTEGER, ",INTEGER"},
743 {OPpSORT_REVERSE, ",REVERSE"},
744 {OPpSORT_INPLACE, ",INPLACE"},
745 {OPpSORT_DESCEND, ",DESCEND"},
746 {OPpSORT_QSORT, ",QSORT"},
747 {OPpSORT_STABLE, ",STABLE"}
750 const struct flag_to_name op_open_names[] = {
751 {OPpOPEN_IN_RAW, ",IN_RAW"},
752 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
753 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
754 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
757 const struct flag_to_name op_exit_names[] = {
758 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
759 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
762 #define OP_PRIVATE_ONCE(op, flag, name) \
763 const struct flag_to_name CAT2(op, _names)[] = { \
767 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
768 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
769 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
770 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
771 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
772 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
773 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
774 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
775 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
776 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
777 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
778 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
780 struct op_private_by_op {
783 const struct flag_to_name *start;
786 const struct op_private_by_op op_private_names[] = {
787 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
788 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
789 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
790 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
791 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
792 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
793 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
794 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
795 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
796 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
797 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
798 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
799 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
800 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
801 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
802 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
803 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
804 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
805 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
806 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
807 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
811 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
812 const struct op_private_by_op *start = op_private_names;
813 const struct op_private_by_op *const end
814 = op_private_names + C_ARRAY_LENGTH(op_private_names);
816 /* This is a linear search, but no worse than the code that it replaced.
817 It's debugging code - size is more important than speed. */
819 if (optype == start->op_type) {
820 S_append_flags(aTHX_ tmpsv, op_private, start->start,
821 start->start + start->len);
824 } while (++start < end);
829 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
833 const OPCODE optype = o->op_type;
835 PERL_ARGS_ASSERT_DO_OP_DUMP;
837 Perl_dump_indent(aTHX_ level, file, "{\n");
839 seq = sequence_num(o);
841 PerlIO_printf(file, "%-4"UVuf, seq);
843 PerlIO_printf(file, "????");
845 "%*sTYPE = %s ===> ",
846 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
849 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
850 sequence_num(o->op_next));
852 PerlIO_printf(file, "NULL\n");
854 if (optype == OP_NULL) {
855 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
856 if (o->op_targ == OP_NEXTSTATE) {
858 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
860 if (CopSTASHPV(cCOPo))
861 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
864 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
869 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
872 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
874 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
875 SV * const tmpsv = newSVpvs("");
876 switch (o->op_flags & OPf_WANT) {
878 sv_catpv(tmpsv, ",VOID");
880 case OPf_WANT_SCALAR:
881 sv_catpv(tmpsv, ",SCALAR");
884 sv_catpv(tmpsv, ",LIST");
887 sv_catpv(tmpsv, ",UNKNOWN");
890 append_flags(tmpsv, o->op_flags, op_flags_names);
892 sv_catpv(tmpsv, ",LATEFREE");
894 sv_catpv(tmpsv, ",LATEFREED");
896 sv_catpv(tmpsv, ",ATTACHED");
897 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
901 SV * const tmpsv = newSVpvs("");
902 if (PL_opargs[optype] & OA_TARGLEX) {
903 if (o->op_private & OPpTARGET_MY)
904 sv_catpv(tmpsv, ",TARGET_MY");
906 else if (optype == OP_ENTERSUB ||
907 optype == OP_RV2SV ||
909 optype == OP_RV2AV ||
910 optype == OP_RV2HV ||
911 optype == OP_RV2GV ||
912 optype == OP_AELEM ||
915 if (optype == OP_ENTERSUB) {
916 append_flags(tmpsv, o->op_private, op_entersub_names);
919 switch (o->op_private & OPpDEREF) {
921 sv_catpv(tmpsv, ",SV");
924 sv_catpv(tmpsv, ",AV");
927 sv_catpv(tmpsv, ",HV");
930 if (o->op_private & OPpMAYBE_LVSUB)
931 sv_catpv(tmpsv, ",MAYBE_LVSUB");
934 if (optype == OP_AELEM || optype == OP_HELEM) {
935 if (o->op_private & OPpLVAL_DEFER)
936 sv_catpv(tmpsv, ",LVAL_DEFER");
939 if (o->op_private & HINT_STRICT_REFS)
940 sv_catpv(tmpsv, ",STRICT_REFS");
941 if (o->op_private & OPpOUR_INTRO)
942 sv_catpv(tmpsv, ",OUR_INTRO");
945 else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
947 else if (PL_check[optype] != Perl_ck_ftst) {
948 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
949 sv_catpv(tmpsv, ",FT_ACCESS");
950 if (o->op_private & OPpFT_STACKED)
951 sv_catpv(tmpsv, ",FT_STACKED");
953 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
954 sv_catpv(tmpsv, ",INTRO");
956 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
961 if (PL_madskills && o->op_madprop) {
962 SV * const tmpsv = newSVpvs("");
963 MADPROP* mp = o->op_madprop;
964 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
967 const char tmp = mp->mad_key;
968 sv_setpvs(tmpsv,"'");
970 sv_catpvn(tmpsv, &tmp, 1);
971 sv_catpv(tmpsv, "'=");
972 switch (mp->mad_type) {
974 sv_catpv(tmpsv, "NULL");
975 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
978 sv_catpv(tmpsv, "<");
979 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
980 sv_catpv(tmpsv, ">");
981 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
984 if ((OP*)mp->mad_val) {
985 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
986 do_op_dump(level, file, (OP*)mp->mad_val);
990 sv_catpv(tmpsv, "(UNK)");
991 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
997 Perl_dump_indent(aTHX_ level, file, "}\n");
1008 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1010 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1011 if (cSVOPo->op_sv) {
1012 SV * const tmpsv = newSV(0);
1016 /* FIXME - is this making unwarranted assumptions about the
1017 UTF-8 cleanliness of the dump file handle? */
1020 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1021 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1022 SvPV_nolen_const(tmpsv));
1026 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1032 case OP_METHOD_NAMED:
1033 #ifndef USE_ITHREADS
1034 /* with ITHREADS, consts are stored in the pad, and the right pad
1035 * may not be active here, so skip */
1036 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1042 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1043 (UV)CopLINE(cCOPo));
1044 if (CopSTASHPV(cCOPo))
1045 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1047 if (CopLABEL(cCOPo))
1048 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1052 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1053 if (cLOOPo->op_redoop)
1054 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1056 PerlIO_printf(file, "DONE\n");
1057 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1058 if (cLOOPo->op_nextop)
1059 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1061 PerlIO_printf(file, "DONE\n");
1062 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1063 if (cLOOPo->op_lastop)
1064 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1066 PerlIO_printf(file, "DONE\n");
1074 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1075 if (cLOGOPo->op_other)
1076 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1078 PerlIO_printf(file, "DONE\n");
1084 do_pmop_dump(level, file, cPMOPo);
1092 if (o->op_private & OPpREFCOUNTED)
1093 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1098 if (o->op_flags & OPf_KIDS) {
1100 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1101 do_op_dump(level, file, kid);
1103 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1107 Perl_op_dump(pTHX_ const OP *o)
1109 PERL_ARGS_ASSERT_OP_DUMP;
1110 do_op_dump(0, Perl_debug_log, o);
1114 Perl_gv_dump(pTHX_ GV *gv)
1118 PERL_ARGS_ASSERT_GV_DUMP;
1121 PerlIO_printf(Perl_debug_log, "{}\n");
1124 sv = sv_newmortal();
1125 PerlIO_printf(Perl_debug_log, "{\n");
1126 gv_fullname3(sv, gv, NULL);
1127 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1128 if (gv != GvEGV(gv)) {
1129 gv_efullname3(sv, GvEGV(gv), NULL);
1130 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1132 PerlIO_putc(Perl_debug_log, '\n');
1133 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1137 /* map magic types to the symbolic names
1138 * (with the PERL_MAGIC_ prefixed stripped)
1141 static const struct { const char type; const char *name; } magic_names[] = {
1142 #include "mg_names.c"
1143 /* this null string terminates the list */
1148 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1150 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1152 for (; mg; mg = mg->mg_moremagic) {
1153 Perl_dump_indent(aTHX_ level, file,
1154 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1155 if (mg->mg_virtual) {
1156 const MGVTBL * const v = mg->mg_virtual;
1157 if (v >= PL_magic_vtables
1158 && v < PL_magic_vtables + magic_vtable_max) {
1159 const U32 i = v - PL_magic_vtables;
1160 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1163 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1166 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1169 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1173 const char *name = NULL;
1174 for (n = 0; magic_names[n].name; n++) {
1175 if (mg->mg_type == magic_names[n].type) {
1176 name = magic_names[n].name;
1181 Perl_dump_indent(aTHX_ level, file,
1182 " MG_TYPE = PERL_MAGIC_%s\n", name);
1184 Perl_dump_indent(aTHX_ level, file,
1185 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1189 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1190 if (mg->mg_type == PERL_MAGIC_envelem &&
1191 mg->mg_flags & MGf_TAINTEDDIR)
1192 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1193 if (mg->mg_type == PERL_MAGIC_regex_global &&
1194 mg->mg_flags & MGf_MINMATCH)
1195 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1196 if (mg->mg_flags & MGf_REFCOUNTED)
1197 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1198 if (mg->mg_flags & MGf_GSKIP)
1199 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1200 if (mg->mg_flags & MGf_COPY)
1201 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1202 if (mg->mg_flags & MGf_DUP)
1203 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1204 if (mg->mg_flags & MGf_LOCAL)
1205 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1208 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1209 PTR2UV(mg->mg_obj));
1210 if (mg->mg_type == PERL_MAGIC_qr) {
1211 REGEXP* const re = (REGEXP *)mg->mg_obj;
1212 SV * const dsv = sv_newmortal();
1213 const char * const s
1214 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1216 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1217 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1219 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1220 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1223 if (mg->mg_flags & MGf_REFCOUNTED)
1224 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1227 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1229 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1230 if (mg->mg_len >= 0) {
1231 if (mg->mg_type != PERL_MAGIC_utf8) {
1232 SV * const sv = newSVpvs("");
1233 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1237 else if (mg->mg_len == HEf_SVKEY) {
1238 PerlIO_puts(file, " => HEf_SVKEY\n");
1239 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1240 maxnest, dumpops, pvlim); /* MG is already +1 */
1243 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1248 " does not know how to handle this MG_LEN"
1250 PerlIO_putc(file, '\n');
1252 if (mg->mg_type == PERL_MAGIC_utf8) {
1253 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1256 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1257 Perl_dump_indent(aTHX_ level, file,
1258 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1261 (UV)cache[i * 2 + 1]);
1268 Perl_magic_dump(pTHX_ const MAGIC *mg)
1270 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1274 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1278 PERL_ARGS_ASSERT_DO_HV_DUMP;
1280 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1281 if (sv && (hvname = HvNAME_get(sv)))
1283 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1284 name which quite legally could contain insane things like tabs, newlines, nulls or
1285 other scary crap - this should produce sane results - except maybe for unicode package
1286 names - but we will wait for someone to file a bug on that - demerphq */
1287 SV * const tmpsv = newSVpvs("");
1288 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1291 PerlIO_putc(file, '\n');
1295 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1297 PERL_ARGS_ASSERT_DO_GV_DUMP;
1299 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1300 if (sv && GvNAME(sv))
1301 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1303 PerlIO_putc(file, '\n');
1307 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1309 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1311 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1312 if (sv && GvNAME(sv)) {
1314 PerlIO_printf(file, "\t\"");
1315 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1316 PerlIO_printf(file, "%s\" :: \"", hvname);
1317 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1320 PerlIO_putc(file, '\n');
1323 const struct flag_to_name first_sv_flags_names[] = {
1324 {SVs_TEMP, "TEMP,"},
1325 {SVs_OBJECT, "OBJECT,"},
1334 const struct flag_to_name second_sv_flags_names[] = {
1336 {SVf_FAKE, "FAKE,"},
1337 {SVf_READONLY, "READONLY,"},
1338 {SVf_BREAK, "BREAK,"},
1339 {SVf_AMAGIC, "OVERLOAD,"},
1345 const struct flag_to_name cv_flags_names[] = {
1346 {CVf_ANON, "ANON,"},
1347 {CVf_UNIQUE, "UNIQUE,"},
1348 {CVf_CLONE, "CLONE,"},
1349 {CVf_CLONED, "CLONED,"},
1350 {CVf_CONST, "CONST,"},
1351 {CVf_NODEBUG, "NODEBUG,"},
1352 {CVf_LVALUE, "LVALUE,"},
1353 {CVf_METHOD, "METHOD,"},
1354 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1355 {CVf_CVGV_RC, "CVGV_RC,"},
1356 {CVf_DYNFILE, "DYNFILE,"},
1357 {CVf_AUTOLOAD, "AUTOLOAD,"},
1358 {CVf_ISXSUB, "ISXSUB,"}
1361 const struct flag_to_name hv_flags_names[] = {
1362 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1363 {SVphv_LAZYDEL, "LAZYDEL,"},
1364 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1365 {SVphv_REHASH, "REHASH,"},
1366 {SVphv_CLONEABLE, "CLONEABLE,"}
1369 const struct flag_to_name gp_flags_names[] = {
1370 {GVf_INTRO, "INTRO,"},
1371 {GVf_MULTI, "MULTI,"},
1372 {GVf_ASSUMECV, "ASSUMECV,"},
1373 {GVf_IN_PAD, "IN_PAD,"}
1376 const struct flag_to_name gp_flags_imported_names[] = {
1377 {GVf_IMPORTED_SV, " SV"},
1378 {GVf_IMPORTED_AV, " AV"},
1379 {GVf_IMPORTED_HV, " HV"},
1380 {GVf_IMPORTED_CV, " CV"},
1383 const struct flag_to_name regexp_flags_names[] = {
1384 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1385 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1386 {RXf_PMf_FOLD, "PMf_FOLD,"},
1387 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1388 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1389 {RXf_ANCH_BOL, "ANCH_BOL,"},
1390 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1391 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1392 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1393 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1394 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1395 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1396 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1397 {RXf_CANY_SEEN, "CANY_SEEN,"},
1398 {RXf_NOSCAN, "NOSCAN,"},
1399 {RXf_CHECK_ALL, "CHECK_ALL,"},
1400 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1401 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1402 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1403 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1404 {RXf_SPLIT, "SPLIT,"},
1405 {RXf_COPY_DONE, "COPY_DONE,"},
1406 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1407 {RXf_TAINTED, "TAINTED,"},
1408 {RXf_START_ONLY, "START_ONLY,"},
1409 {RXf_SKIPWHITE, "SKIPWHITE,"},
1410 {RXf_WHITE, "WHITE,"},
1411 {RXf_NULL, "NULL,"},
1415 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1423 PERL_ARGS_ASSERT_DO_SV_DUMP;
1426 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1430 flags = SvFLAGS(sv);
1433 /* process general SV flags */
1435 d = Perl_newSVpvf(aTHX_
1436 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1437 PTR2UV(SvANY(sv)), PTR2UV(sv),
1438 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1439 (int)(PL_dumpindent*level), "");
1441 if (!((flags & SVpad_NAME) == SVpad_NAME
1442 && (type == SVt_PVMG || type == SVt_PVNV))) {
1443 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1444 sv_catpv(d, "PADSTALE,");
1446 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1447 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1448 sv_catpv(d, "PADTMP,");
1449 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1451 append_flags(d, flags, first_sv_flags_names);
1452 if (flags & SVf_ROK) {
1453 sv_catpv(d, "ROK,");
1454 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1456 append_flags(d, flags, second_sv_flags_names);
1457 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1458 if (SvPCS_IMPORTED(sv))
1459 sv_catpv(d, "PCS_IMPORTED,");
1461 sv_catpv(d, "SCREAM,");
1464 /* process type-specific SV flags */
1469 append_flags(d, CvFLAGS(sv), cv_flags_names);
1472 append_flags(d, flags, hv_flags_names);
1476 if (isGV_with_GP(sv)) {
1477 append_flags(d, GvFLAGS(sv), gp_flags_names);
1479 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1480 sv_catpv(d, "IMPORT");
1481 if (GvIMPORTED(sv) == GVf_IMPORTED)
1482 sv_catpv(d, "ALL,");
1485 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1492 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1493 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1496 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1497 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1498 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1499 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1502 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1507 /* SVphv_SHAREKEYS is also 0x20000000 */
1508 if ((type != SVt_PVHV) && SvUTF8(sv))
1509 sv_catpv(d, "UTF8");
1511 if (*(SvEND(d) - 1) == ',') {
1512 SvCUR_set(d, SvCUR(d) - 1);
1513 SvPVX(d)[SvCUR(d)] = '\0';
1518 /* dump initial SV details */
1520 #ifdef DEBUG_LEAKING_SCALARS
1521 Perl_dump_indent(aTHX_ level, file,
1522 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1523 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1525 sv->sv_debug_inpad ? "for" : "by",
1526 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1527 PTR2UV(sv->sv_debug_parent),
1531 Perl_dump_indent(aTHX_ level, file, "SV = ");
1535 if (type < SVt_LAST) {
1536 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1538 if (type == SVt_NULL) {
1543 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1548 /* Dump general SV fields */
1550 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1551 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1552 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1553 || (type == SVt_IV && !SvROK(sv))) {
1555 #ifdef PERL_OLD_COPY_ON_WRITE
1559 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1561 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1562 #ifdef PERL_OLD_COPY_ON_WRITE
1563 if (SvIsCOW_shared_hash(sv))
1564 PerlIO_printf(file, " (HASH)");
1565 else if (SvIsCOW_normal(sv))
1566 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1568 PerlIO_putc(file, '\n');
1571 if ((type == SVt_PVNV || type == SVt_PVMG)
1572 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1573 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1574 (UV) COP_SEQ_RANGE_LOW(sv));
1575 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1576 (UV) COP_SEQ_RANGE_HIGH(sv));
1577 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1578 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1579 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1580 || type == SVt_NV) {
1581 STORE_NUMERIC_LOCAL_SET_STANDARD();
1582 /* %Vg doesn't work? --jhi */
1583 #ifdef USE_LONG_DOUBLE
1584 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1586 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1588 RESTORE_NUMERIC_LOCAL();
1592 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1594 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1597 if (type < SVt_PV) {
1602 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1603 if (SvPVX_const(sv)) {
1606 SvOOK_offset(sv, delta);
1607 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1612 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1614 PerlIO_printf(file, "( %s . ) ",
1615 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1618 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1619 if (SvUTF8(sv)) /* the 6? \x{....} */
1620 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1621 PerlIO_printf(file, "\n");
1622 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1623 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1626 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1629 if (type >= SVt_PVMG) {
1630 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1631 HV * const ost = SvOURSTASH(sv);
1633 do_hv_dump(level, file, " OURSTASH", ost);
1636 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1639 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1641 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1642 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1643 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1644 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1648 /* Dump type-specific SV fields */
1652 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1653 if (AvARRAY(sv) != AvALLOC(sv)) {
1654 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1655 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1658 PerlIO_putc(file, '\n');
1659 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1660 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1661 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1663 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1664 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1665 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1666 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1667 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1669 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1670 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1672 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1674 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1679 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1680 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1681 /* Show distribution of HEs in the ARRAY */
1683 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1686 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1687 NV theoret, sum = 0;
1689 PerlIO_printf(file, " (");
1690 Zero(freq, FREQ_MAX + 1, int);
1691 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1694 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1696 if (count > FREQ_MAX)
1702 for (i = 0; i <= max; i++) {
1704 PerlIO_printf(file, "%d%s:%d", i,
1705 (i == FREQ_MAX) ? "+" : "",
1708 PerlIO_printf(file, ", ");
1711 PerlIO_putc(file, ')');
1712 /* The "quality" of a hash is defined as the total number of
1713 comparisons needed to access every element once, relative
1714 to the expected number needed for a random hash.
1716 The total number of comparisons is equal to the sum of
1717 the squares of the number of entries in each bucket.
1718 For a random hash of n keys into k buckets, the expected
1723 for (i = max; i > 0; i--) { /* Precision: count down. */
1724 sum += freq[i] * i * i;
1726 while ((keys = keys >> 1))
1728 theoret = HvUSEDKEYS(sv);
1729 theoret += theoret * (theoret-1)/pow2;
1730 PerlIO_putc(file, '\n');
1731 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1733 PerlIO_putc(file, '\n');
1734 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1735 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1736 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1737 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1738 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1740 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1741 if (mg && mg->mg_obj) {
1742 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1746 const char * const hvname = HvNAME_get(sv);
1748 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1752 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1753 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1754 if (HvAUX(sv)->xhv_name_count)
1755 Perl_dump_indent(aTHX_
1756 level, file, " NAMECOUNT = %"IVdf"\n",
1757 (IV)HvAUX(sv)->xhv_name_count
1759 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1760 const I32 count = HvAUX(sv)->xhv_name_count;
1762 SV * const names = newSVpvs_flags("", SVs_TEMP);
1763 /* The starting point is the first element if count is
1764 positive and the second element if count is negative. */
1765 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1766 + (count < 0 ? 1 : 0);
1767 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1768 + (count < 0 ? -count : count);
1769 while (hekp < endp) {
1771 sv_catpvs(names, ", \"");
1772 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1773 sv_catpvs(names, "\"");
1775 /* This should never happen. */
1776 sv_catpvs(names, ", (null)");
1780 Perl_dump_indent(aTHX_
1781 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1785 Perl_dump_indent(aTHX_
1786 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1790 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1792 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1796 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1797 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1798 (int)meta->mro_which->length,
1799 meta->mro_which->name,
1800 PTR2UV(meta->mro_which));
1801 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1802 (UV)meta->cache_gen);
1803 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1805 if (meta->mro_linear_all) {
1806 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1807 PTR2UV(meta->mro_linear_all));
1808 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1811 if (meta->mro_linear_current) {
1812 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1813 PTR2UV(meta->mro_linear_current));
1814 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1817 if (meta->mro_nextmethod) {
1818 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1819 PTR2UV(meta->mro_nextmethod));
1820 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1824 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1826 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1831 if (nest < maxnest) {
1832 HV * const hv = MUTABLE_HV(sv);
1837 int count = maxnest - nest;
1838 for (i=0; i <= HvMAX(hv); i++) {
1839 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1846 if (count-- <= 0) goto DONEHV;
1849 keysv = hv_iterkeysv(he);
1850 keypv = SvPV_const(keysv, len);
1853 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1855 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1856 if (HvEITER_get(hv) == he)
1857 PerlIO_printf(file, "[CURRENT] ");
1859 PerlIO_printf(file, "[REHASH] ");
1860 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1861 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1870 if (CvAUTOLOAD(sv)) {
1872 const char *const name = SvPV_const(sv, len);
1873 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1877 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1878 (int) CvPROTOLEN(sv), CvPROTO(sv));
1882 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1883 if (!CvISXSUB(sv)) {
1885 Perl_dump_indent(aTHX_ level, file,
1886 " START = 0x%"UVxf" ===> %"IVdf"\n",
1887 PTR2UV(CvSTART(sv)),
1888 (IV)sequence_num(CvSTART(sv)));
1890 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1891 PTR2UV(CvROOT(sv)));
1892 if (CvROOT(sv) && dumpops) {
1893 do_op_dump(level+1, file, CvROOT(sv));
1896 SV * const constant = cv_const_sv((const CV *)sv);
1898 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1901 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1903 PTR2UV(CvXSUBANY(sv).any_ptr));
1904 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1907 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1908 (IV)CvXSUBANY(sv).any_i32);
1911 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1912 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1913 if (type == SVt_PVCV)
1914 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1915 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1916 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1917 if (type == SVt_PVFM)
1918 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1919 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1920 if (nest < maxnest) {
1921 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1924 const CV * const outside = CvOUTSIDE(sv);
1925 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1928 : CvANON(outside) ? "ANON"
1929 : (outside == PL_main_cv) ? "MAIN"
1930 : CvUNIQUE(outside) ? "UNIQUE"
1931 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1933 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1934 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1939 if (type == SVt_PVLV) {
1940 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1941 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1942 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1943 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1944 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
1945 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1946 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1949 if (!isGV_with_GP(sv))
1951 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1952 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1953 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1954 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1957 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1958 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1959 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1960 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1961 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1962 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1963 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1964 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1965 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1966 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1967 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1968 do_gv_dump (level, file, " EGV", GvEGV(sv));
1971 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1972 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1973 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1974 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1975 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1976 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1977 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1979 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1980 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1981 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1983 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1984 PTR2UV(IoTOP_GV(sv)));
1985 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1986 maxnest, dumpops, pvlim);
1988 /* Source filters hide things that are not GVs in these three, so let's
1989 be careful out there. */
1991 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1992 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1993 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1995 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1996 PTR2UV(IoFMT_GV(sv)));
1997 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1998 maxnest, dumpops, pvlim);
2000 if (IoBOTTOM_NAME(sv))
2001 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2002 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2003 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2005 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2006 PTR2UV(IoBOTTOM_GV(sv)));
2007 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2008 maxnest, dumpops, pvlim);
2010 if (isPRINT(IoTYPE(sv)))
2011 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2013 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2014 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2018 struct regexp * const r = (struct regexp *)SvANY(sv);
2019 flags = RX_EXTFLAGS((REGEXP*)sv);
2021 append_flags(d, flags, regexp_flags_names);
2022 if (*(SvEND(d) - 1) == ',') {
2023 SvCUR_set(d, SvCUR(d) - 1);
2024 SvPVX(d)[SvCUR(d)] = '\0';
2026 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2027 (UV)flags, SvPVX_const(d));
2028 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2030 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2032 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2033 (UV)(r->lastparen));
2034 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2035 (UV)(r->lastcloseparen));
2036 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2038 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2039 (IV)(r->minlenret));
2040 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2042 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2043 (UV)(r->pre_prefix));
2044 Perl_dump_indent(aTHX_ level, file, " SEEN_EVALS = %"UVuf"\n",
2045 (UV)(r->seen_evals));
2046 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2049 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2051 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2053 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2054 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2056 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2057 PTR2UV(r->mother_re));
2058 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2059 PTR2UV(r->paren_names));
2060 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2061 PTR2UV(r->substrs));
2062 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2063 PTR2UV(r->pprivate));
2064 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2066 #ifdef PERL_OLD_COPY_ON_WRITE
2067 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2068 PTR2UV(r->saved_copy));
2077 Perl_sv_dump(pTHX_ SV *sv)
2081 PERL_ARGS_ASSERT_SV_DUMP;
2084 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2086 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2090 Perl_runops_debug(pTHX)
2094 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2098 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2101 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2102 PerlIO_printf(Perl_debug_log,
2103 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2104 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2105 PTR2UV(*PL_watchaddr));
2106 if (DEBUG_s_TEST_) {
2107 if (DEBUG_v_TEST_) {
2108 PerlIO_printf(Perl_debug_log, "\n");
2116 if (DEBUG_t_TEST_) debop(PL_op);
2117 if (DEBUG_P_TEST_) debprof(PL_op);
2119 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2120 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2127 Perl_debop(pTHX_ const OP *o)
2131 PERL_ARGS_ASSERT_DEBOP;
2133 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2136 Perl_deb(aTHX_ "%s", OP_NAME(o));
2137 switch (o->op_type) {
2140 /* With ITHREADS, consts are stored in the pad, and the right pad
2141 * may not be active here, so check.
2142 * Looks like only during compiling the pads are illegal.
2145 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2147 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2152 SV * const sv = newSV(0);
2154 /* FIXME - is this making unwarranted assumptions about the
2155 UTF-8 cleanliness of the dump file handle? */
2158 gv_fullname3(sv, cGVOPo_gv, NULL);
2159 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2163 PerlIO_printf(Perl_debug_log, "(NULL)");
2169 /* print the lexical's name */
2170 CV * const cv = deb_curcv(cxstack_ix);
2173 AV * const padlist = CvPADLIST(cv);
2174 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2175 sv = *av_fetch(comppad, o->op_targ, FALSE);
2179 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2181 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2187 PerlIO_printf(Perl_debug_log, "\n");
2192 S_deb_curcv(pTHX_ const I32 ix)
2195 const PERL_CONTEXT * const cx = &cxstack[ix];
2196 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2197 return cx->blk_sub.cv;
2198 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2199 return cx->blk_eval.cv;
2200 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2205 return deb_curcv(ix - 1);
2209 Perl_watch(pTHX_ char **addr)
2213 PERL_ARGS_ASSERT_WATCH;
2215 PL_watchaddr = addr;
2217 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2218 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2222 S_debprof(pTHX_ const OP *o)
2226 PERL_ARGS_ASSERT_DEBPROF;
2228 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2230 if (!PL_profiledata)
2231 Newxz(PL_profiledata, MAXO, U32);
2232 ++PL_profiledata[o->op_type];
2236 Perl_debprofdump(pTHX)
2240 if (!PL_profiledata)
2242 for (i = 0; i < MAXO; i++) {
2243 if (PL_profiledata[i])
2244 PerlIO_printf(Perl_debug_log,
2245 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2252 * XML variants of most of the above routines
2256 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2260 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2262 PerlIO_printf(file, "\n ");
2263 va_start(args, pat);
2264 xmldump_vindent(level, file, pat, &args);
2270 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2273 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2274 va_start(args, pat);
2275 xmldump_vindent(level, file, pat, &args);
2280 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2282 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2284 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2285 PerlIO_vprintf(file, pat, *args);
2289 Perl_xmldump_all(pTHX)
2291 xmldump_all_perl(FALSE);
2295 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2297 PerlIO_setlinebuf(PL_xmlfp);
2299 op_xmldump(PL_main_root);
2300 /* someday we might call this, when it outputs XML: */
2301 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2302 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2303 PerlIO_close(PL_xmlfp);
2308 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2310 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2311 xmldump_packsubs_perl(stash, FALSE);
2315 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2320 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2322 if (!HvARRAY(stash))
2324 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2325 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2326 GV *gv = MUTABLE_GV(HeVAL(entry));
2328 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2331 xmldump_sub_perl(gv, justperl);
2334 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2335 && (hv = GvHV(gv)) && hv != PL_defstash)
2336 xmldump_packsubs_perl(hv, justperl); /* nested package */
2342 Perl_xmldump_sub(pTHX_ const GV *gv)
2344 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2345 xmldump_sub_perl(gv, FALSE);
2349 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2353 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2355 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2358 sv = sv_newmortal();
2359 gv_fullname3(sv, gv, NULL);
2360 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2361 if (CvXSUB(GvCV(gv)))
2362 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2363 PTR2UV(CvXSUB(GvCV(gv))),
2364 (int)CvXSUBANY(GvCV(gv)).any_i32);
2365 else if (CvROOT(GvCV(gv)))
2366 op_xmldump(CvROOT(GvCV(gv)));
2368 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2372 Perl_xmldump_form(pTHX_ const GV *gv)
2374 SV * const sv = sv_newmortal();
2376 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2378 gv_fullname3(sv, gv, NULL);
2379 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2380 if (CvROOT(GvFORM(gv)))
2381 op_xmldump(CvROOT(GvFORM(gv)));
2383 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2387 Perl_xmldump_eval(pTHX)
2389 op_xmldump(PL_eval_root);
2393 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2395 PERL_ARGS_ASSERT_SV_CATXMLSV;
2396 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2400 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2402 PERL_ARGS_ASSERT_SV_CATXMLPV;
2403 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2407 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2410 const char * const e = pv + len;
2411 const char * const start = pv;
2415 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2418 dsvcur = SvCUR(dsv); /* in case we have to restart */
2423 c = utf8_to_uvchr((U8*)pv, &cl);
2425 SvCUR(dsv) = dsvcur;
2490 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2493 sv_catpvs(dsv, "<");
2496 sv_catpvs(dsv, ">");
2499 sv_catpvs(dsv, "&");
2502 sv_catpvs(dsv, """);
2506 if (c < 32 || c > 127) {
2507 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2510 const char string = (char) c;
2511 sv_catpvn(dsv, &string, 1);
2515 if ((c >= 0xD800 && c <= 0xDB7F) ||
2516 (c >= 0xDC00 && c <= 0xDFFF) ||
2517 (c >= 0xFFF0 && c <= 0xFFFF) ||
2519 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2521 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2534 Perl_sv_xmlpeek(pTHX_ SV *sv)
2536 SV * const t = sv_newmortal();
2540 PERL_ARGS_ASSERT_SV_XMLPEEK;
2546 sv_catpv(t, "VOID=\"\"");
2549 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2550 sv_catpv(t, "WILD=\"\"");
2553 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2554 if (sv == &PL_sv_undef) {
2555 sv_catpv(t, "SV_UNDEF=\"1\"");
2556 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2557 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2561 else if (sv == &PL_sv_no) {
2562 sv_catpv(t, "SV_NO=\"1\"");
2563 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2564 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2565 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2566 SVp_POK|SVp_NOK)) &&
2571 else if (sv == &PL_sv_yes) {
2572 sv_catpv(t, "SV_YES=\"1\"");
2573 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2574 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2575 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2576 SVp_POK|SVp_NOK)) &&
2578 SvPVX(sv) && *SvPVX(sv) == '1' &&
2583 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2584 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2585 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2589 sv_catpv(t, " XXX=\"\" ");
2591 else if (SvREFCNT(sv) == 0) {
2592 sv_catpv(t, " refcnt=\"0\"");
2595 else if (DEBUG_R_TEST_) {
2598 /* is this SV on the tmps stack? */
2599 for (ix=PL_tmps_ix; ix>=0; ix--) {
2600 if (PL_tmps_stack[ix] == sv) {
2605 if (SvREFCNT(sv) > 1)
2606 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2609 sv_catpv(t, " DRT=\"<T>\"");
2613 sv_catpv(t, " ROK=\"\"");
2615 switch (SvTYPE(sv)) {
2617 sv_catpv(t, " FREED=\"1\"");
2621 sv_catpv(t, " UNDEF=\"1\"");
2624 sv_catpv(t, " IV=\"");
2627 sv_catpv(t, " NV=\"");
2630 sv_catpv(t, " PV=\"");
2633 sv_catpv(t, " PVIV=\"");
2636 sv_catpv(t, " PVNV=\"");
2639 sv_catpv(t, " PVMG=\"");
2642 sv_catpv(t, " PVLV=\"");
2645 sv_catpv(t, " AV=\"");
2648 sv_catpv(t, " HV=\"");
2652 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2654 sv_catpv(t, " CV=\"()\"");
2657 sv_catpv(t, " GV=\"");
2660 sv_catpv(t, " BIND=\"");
2663 sv_catpv(t, " REGEXP=\"");
2666 sv_catpv(t, " FM=\"");
2669 sv_catpv(t, " IO=\"");
2678 else if (SvNOKp(sv)) {
2679 STORE_NUMERIC_LOCAL_SET_STANDARD();
2680 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2681 RESTORE_NUMERIC_LOCAL();
2683 else if (SvIOKp(sv)) {
2685 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2687 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2696 return SvPV(t, n_a);
2700 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2702 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2705 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2708 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2711 REGEXP *const r = PM_GETRE(pm);
2712 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2713 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2714 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2716 SvREFCNT_dec(tmpsv);
2717 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2718 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2721 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2722 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2723 SV * const tmpsv = pm_description(pm);
2724 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2725 SvREFCNT_dec(tmpsv);
2729 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2730 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2731 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2732 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2733 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2734 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2737 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2741 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2743 do_pmop_xmldump(0, PL_xmlfp, pm);
2747 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2752 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2756 seq = sequence_num(o);
2757 Perl_xmldump_indent(aTHX_ level, file,
2758 "<op_%s seq=\"%"UVuf" -> ",
2763 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2764 sequence_num(o->op_next));
2766 PerlIO_printf(file, "DONE\"");
2769 if (o->op_type == OP_NULL)
2771 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2772 if (o->op_targ == OP_NEXTSTATE)
2775 PerlIO_printf(file, " line=\"%"UVuf"\"",
2776 (UV)CopLINE(cCOPo));
2777 if (CopSTASHPV(cCOPo))
2778 PerlIO_printf(file, " package=\"%s\"",
2780 if (CopLABEL(cCOPo))
2781 PerlIO_printf(file, " label=\"%s\"",
2786 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2789 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2792 SV * const tmpsv = newSVpvs("");
2793 switch (o->op_flags & OPf_WANT) {
2795 sv_catpv(tmpsv, ",VOID");
2797 case OPf_WANT_SCALAR:
2798 sv_catpv(tmpsv, ",SCALAR");
2801 sv_catpv(tmpsv, ",LIST");
2804 sv_catpv(tmpsv, ",UNKNOWN");
2807 if (o->op_flags & OPf_KIDS)
2808 sv_catpv(tmpsv, ",KIDS");
2809 if (o->op_flags & OPf_PARENS)
2810 sv_catpv(tmpsv, ",PARENS");
2811 if (o->op_flags & OPf_STACKED)
2812 sv_catpv(tmpsv, ",STACKED");
2813 if (o->op_flags & OPf_REF)
2814 sv_catpv(tmpsv, ",REF");
2815 if (o->op_flags & OPf_MOD)
2816 sv_catpv(tmpsv, ",MOD");
2817 if (o->op_flags & OPf_SPECIAL)
2818 sv_catpv(tmpsv, ",SPECIAL");
2819 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2820 SvREFCNT_dec(tmpsv);
2822 if (o->op_private) {
2823 SV * const tmpsv = newSVpvs("");
2824 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2825 if (o->op_private & OPpTARGET_MY)
2826 sv_catpv(tmpsv, ",TARGET_MY");
2828 else if (o->op_type == OP_LEAVESUB ||
2829 o->op_type == OP_LEAVE ||
2830 o->op_type == OP_LEAVESUBLV ||
2831 o->op_type == OP_LEAVEWRITE) {
2832 if (o->op_private & OPpREFCOUNTED)
2833 sv_catpv(tmpsv, ",REFCOUNTED");
2835 else if (o->op_type == OP_AASSIGN) {
2836 if (o->op_private & OPpASSIGN_COMMON)
2837 sv_catpv(tmpsv, ",COMMON");
2839 else if (o->op_type == OP_SASSIGN) {
2840 if (o->op_private & OPpASSIGN_BACKWARDS)
2841 sv_catpv(tmpsv, ",BACKWARDS");
2843 else if (o->op_type == OP_TRANS) {
2844 if (o->op_private & OPpTRANS_SQUASH)
2845 sv_catpv(tmpsv, ",SQUASH");
2846 if (o->op_private & OPpTRANS_DELETE)
2847 sv_catpv(tmpsv, ",DELETE");
2848 if (o->op_private & OPpTRANS_COMPLEMENT)
2849 sv_catpv(tmpsv, ",COMPLEMENT");
2850 if (o->op_private & OPpTRANS_IDENTICAL)
2851 sv_catpv(tmpsv, ",IDENTICAL");
2852 if (o->op_private & OPpTRANS_GROWS)
2853 sv_catpv(tmpsv, ",GROWS");
2855 else if (o->op_type == OP_REPEAT) {
2856 if (o->op_private & OPpREPEAT_DOLIST)
2857 sv_catpv(tmpsv, ",DOLIST");
2859 else if (o->op_type == OP_ENTERSUB ||
2860 o->op_type == OP_RV2SV ||
2861 o->op_type == OP_GVSV ||
2862 o->op_type == OP_RV2AV ||
2863 o->op_type == OP_RV2HV ||
2864 o->op_type == OP_RV2GV ||
2865 o->op_type == OP_AELEM ||
2866 o->op_type == OP_HELEM )
2868 if (o->op_type == OP_ENTERSUB) {
2869 if (o->op_private & OPpENTERSUB_AMPER)
2870 sv_catpv(tmpsv, ",AMPER");
2871 if (o->op_private & OPpENTERSUB_DB)
2872 sv_catpv(tmpsv, ",DB");
2873 if (o->op_private & OPpENTERSUB_HASTARG)
2874 sv_catpv(tmpsv, ",HASTARG");
2875 if (o->op_private & OPpENTERSUB_NOPAREN)
2876 sv_catpv(tmpsv, ",NOPAREN");
2877 if (o->op_private & OPpENTERSUB_INARGS)
2878 sv_catpv(tmpsv, ",INARGS");
2881 switch (o->op_private & OPpDEREF) {
2883 sv_catpv(tmpsv, ",SV");
2886 sv_catpv(tmpsv, ",AV");
2889 sv_catpv(tmpsv, ",HV");
2892 if (o->op_private & OPpMAYBE_LVSUB)
2893 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2895 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2896 if (o->op_private & OPpLVAL_DEFER)
2897 sv_catpv(tmpsv, ",LVAL_DEFER");
2900 if (o->op_private & HINT_STRICT_REFS)
2901 sv_catpv(tmpsv, ",STRICT_REFS");
2902 if (o->op_private & OPpOUR_INTRO)
2903 sv_catpv(tmpsv, ",OUR_INTRO");
2906 else if (o->op_type == OP_CONST) {
2907 if (o->op_private & OPpCONST_BARE)
2908 sv_catpv(tmpsv, ",BARE");
2909 if (o->op_private & OPpCONST_STRICT)
2910 sv_catpv(tmpsv, ",STRICT");
2911 if (o->op_private & OPpCONST_WARNING)
2912 sv_catpv(tmpsv, ",WARNING");
2913 if (o->op_private & OPpCONST_ENTERED)
2914 sv_catpv(tmpsv, ",ENTERED");
2916 else if (o->op_type == OP_FLIP) {
2917 if (o->op_private & OPpFLIP_LINENUM)
2918 sv_catpv(tmpsv, ",LINENUM");
2920 else if (o->op_type == OP_FLOP) {
2921 if (o->op_private & OPpFLIP_LINENUM)
2922 sv_catpv(tmpsv, ",LINENUM");
2924 else if (o->op_type == OP_RV2CV) {
2925 if (o->op_private & OPpLVAL_INTRO)
2926 sv_catpv(tmpsv, ",INTRO");
2928 else if (o->op_type == OP_GV) {
2929 if (o->op_private & OPpEARLY_CV)
2930 sv_catpv(tmpsv, ",EARLY_CV");
2932 else if (o->op_type == OP_LIST) {
2933 if (o->op_private & OPpLIST_GUESSED)
2934 sv_catpv(tmpsv, ",GUESSED");
2936 else if (o->op_type == OP_DELETE) {
2937 if (o->op_private & OPpSLICE)
2938 sv_catpv(tmpsv, ",SLICE");
2940 else if (o->op_type == OP_EXISTS) {
2941 if (o->op_private & OPpEXISTS_SUB)
2942 sv_catpv(tmpsv, ",EXISTS_SUB");
2944 else if (o->op_type == OP_SORT) {
2945 if (o->op_private & OPpSORT_NUMERIC)
2946 sv_catpv(tmpsv, ",NUMERIC");
2947 if (o->op_private & OPpSORT_INTEGER)
2948 sv_catpv(tmpsv, ",INTEGER");
2949 if (o->op_private & OPpSORT_REVERSE)
2950 sv_catpv(tmpsv, ",REVERSE");
2952 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2953 if (o->op_private & OPpOPEN_IN_RAW)
2954 sv_catpv(tmpsv, ",IN_RAW");
2955 if (o->op_private & OPpOPEN_IN_CRLF)
2956 sv_catpv(tmpsv, ",IN_CRLF");
2957 if (o->op_private & OPpOPEN_OUT_RAW)
2958 sv_catpv(tmpsv, ",OUT_RAW");
2959 if (o->op_private & OPpOPEN_OUT_CRLF)
2960 sv_catpv(tmpsv, ",OUT_CRLF");
2962 else if (o->op_type == OP_EXIT) {
2963 if (o->op_private & OPpEXIT_VMSISH)
2964 sv_catpv(tmpsv, ",EXIT_VMSISH");
2965 if (o->op_private & OPpHUSH_VMSISH)
2966 sv_catpv(tmpsv, ",HUSH_VMSISH");
2968 else if (o->op_type == OP_DIE) {
2969 if (o->op_private & OPpHUSH_VMSISH)
2970 sv_catpv(tmpsv, ",HUSH_VMSISH");
2972 else if (PL_check[o->op_type] != Perl_ck_ftst) {
2973 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2974 sv_catpv(tmpsv, ",FT_ACCESS");
2975 if (o->op_private & OPpFT_STACKED)
2976 sv_catpv(tmpsv, ",FT_STACKED");
2978 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2979 sv_catpv(tmpsv, ",INTRO");
2981 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2982 SvREFCNT_dec(tmpsv);
2985 switch (o->op_type) {
2987 if (o->op_flags & OPf_SPECIAL) {
2993 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2995 if (cSVOPo->op_sv) {
2996 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2997 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3003 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3004 s = SvPV(tmpsv1,len);
3005 sv_catxmlpvn(tmpsv2, s, len, 1);
3006 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3010 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3015 case OP_METHOD_NAMED:
3016 #ifndef USE_ITHREADS
3017 /* with ITHREADS, consts are stored in the pad, and the right pad
3018 * may not be active here, so skip */
3019 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3025 PerlIO_printf(file, ">\n");
3027 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3032 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3033 (UV)CopLINE(cCOPo));
3034 if (CopSTASHPV(cCOPo))
3035 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3037 if (CopLABEL(cCOPo))
3038 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3042 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3043 if (cLOOPo->op_redoop)
3044 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3046 PerlIO_printf(file, "DONE\"");
3047 S_xmldump_attr(aTHX_ level, file, "next=\"");
3048 if (cLOOPo->op_nextop)
3049 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3051 PerlIO_printf(file, "DONE\"");
3052 S_xmldump_attr(aTHX_ level, file, "last=\"");
3053 if (cLOOPo->op_lastop)
3054 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3056 PerlIO_printf(file, "DONE\"");
3064 S_xmldump_attr(aTHX_ level, file, "other=\"");
3065 if (cLOGOPo->op_other)
3066 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3068 PerlIO_printf(file, "DONE\"");
3076 if (o->op_private & OPpREFCOUNTED)
3077 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3083 if (PL_madskills && o->op_madprop) {
3084 char prevkey = '\0';
3085 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3086 const MADPROP* mp = o->op_madprop;
3090 PerlIO_printf(file, ">\n");
3092 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3095 char tmp = mp->mad_key;
3096 sv_setpvs(tmpsv,"\"");
3098 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3099 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3100 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3103 sv_catpv(tmpsv, "\"");
3104 switch (mp->mad_type) {
3106 sv_catpv(tmpsv, "NULL");
3107 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3110 sv_catpv(tmpsv, " val=\"");
3111 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3112 sv_catpv(tmpsv, "\"");
3113 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3116 sv_catpv(tmpsv, " val=\"");
3117 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3118 sv_catpv(tmpsv, "\"");
3119 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3122 if ((OP*)mp->mad_val) {
3123 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3124 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3125 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3129 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3135 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3137 SvREFCNT_dec(tmpsv);
3140 switch (o->op_type) {
3147 PerlIO_printf(file, ">\n");
3149 do_pmop_xmldump(level, file, cPMOPo);
3155 if (o->op_flags & OPf_KIDS) {
3159 PerlIO_printf(file, ">\n");
3161 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3162 do_op_xmldump(level, file, kid);
3166 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3168 PerlIO_printf(file, " />\n");
3172 Perl_op_xmldump(pTHX_ const OP *o)
3174 PERL_ARGS_ASSERT_OP_XMLDUMP;
3176 do_op_xmldump(0, PL_xmlfp, o);
3182 * c-indentation-style: bsd
3184 * indent-tabs-mode: t
3187 * ex: set ts=8 sts=4 sw=4 noet: