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))
90 #define Sequence PL_op_sequence
93 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
96 PERL_ARGS_ASSERT_DUMP_INDENT;
98 dump_vindent(level, file, pat, &args);
103 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
106 PERL_ARGS_ASSERT_DUMP_VINDENT;
107 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
108 PerlIO_vprintf(file, pat, *args);
114 dump_all_perl(FALSE);
118 Perl_dump_all_perl(pTHX_ bool justperl)
122 PerlIO_setlinebuf(Perl_debug_log);
124 op_dump(PL_main_root);
125 dump_packsubs_perl(PL_defstash, justperl);
129 Perl_dump_packsubs(pTHX_ const HV *stash)
131 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
132 dump_packsubs_perl(stash, FALSE);
136 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
141 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
145 for (i = 0; i <= (I32) HvMAX(stash); i++) {
147 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
148 const GV * const gv = (const GV *)HeVAL(entry);
149 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
152 dump_sub_perl(gv, justperl);
155 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
156 const HV * const hv = GvHV(gv);
157 if (hv && (hv != PL_defstash))
158 dump_packsubs_perl(hv, justperl); /* nested package */
165 Perl_dump_sub(pTHX_ const GV *gv)
167 PERL_ARGS_ASSERT_DUMP_SUB;
168 dump_sub_perl(gv, FALSE);
172 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
176 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
178 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
182 gv_fullname3(sv, gv, NULL);
183 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
184 if (CvISXSUB(GvCV(gv)))
185 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
186 PTR2UV(CvXSUB(GvCV(gv))),
187 (int)CvXSUBANY(GvCV(gv)).any_i32);
188 else if (CvROOT(GvCV(gv)))
189 op_dump(CvROOT(GvCV(gv)));
191 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
195 Perl_dump_form(pTHX_ const GV *gv)
197 SV * const sv = sv_newmortal();
199 PERL_ARGS_ASSERT_DUMP_FORM;
201 gv_fullname3(sv, gv, NULL);
202 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
203 if (CvROOT(GvFORM(gv)))
204 op_dump(CvROOT(GvFORM(gv)));
206 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
213 op_dump(PL_eval_root);
218 =for apidoc pv_escape
220 Escapes at most the first "count" chars of pv and puts the results into
221 dsv such that the size of the escaped string will not exceed "max" chars
222 and will not contain any incomplete escape sequences.
224 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
225 will also be escaped.
227 Normally the SV will be cleared before the escaped string is prepared,
228 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
230 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
231 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
232 using C<is_utf8_string()> to determine if it is Unicode.
234 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
235 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
236 chars above 127 will be escaped using this style; otherwise, only chars above
237 255 will be so escaped; other non printable chars will use octal or
238 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
239 then all chars below 255 will be treated as printable and
240 will be output as literals.
242 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
243 string will be escaped, regardless of max. If the output is to be in hex,
244 then it will be returned as a plain hex
245 sequence. Thus the output will either be a single char,
246 an octal escape sequence, a special escape like C<\n> or a hex value.
248 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
249 not a '\\'. This is because regexes very often contain backslashed
250 sequences, whereas '%' is not a particularly common character in patterns.
252 Returns a pointer to the escaped text as held by dsv.
256 #define PV_ESCAPE_OCTBUFSIZE 32
259 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
260 const STRLEN count, const STRLEN max,
261 STRLEN * const escaped, const U32 flags )
263 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
264 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
265 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
266 STRLEN wrote = 0; /* chars written so far */
267 STRLEN chsize = 0; /* size of data to be written */
268 STRLEN readsize = 1; /* size of data just read */
269 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
270 const char *pv = str;
271 const char * const end = pv + count; /* end of string */
274 PERL_ARGS_ASSERT_PV_ESCAPE;
276 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
277 /* This won't alter the UTF-8 flag */
281 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
284 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
285 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
286 const U8 c = (U8)u & 0xFF;
289 || (flags & PERL_PV_ESCAPE_ALL)
290 || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
292 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
293 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
296 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
297 "%cx{%"UVxf"}", esc, u);
298 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
301 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
305 case '\\' : /* fallthrough */
306 case '%' : if ( c == esc ) {
312 case '\v' : octbuf[1] = 'v'; break;
313 case '\t' : octbuf[1] = 't'; break;
314 case '\r' : octbuf[1] = 'r'; break;
315 case '\n' : octbuf[1] = 'n'; break;
316 case '\f' : octbuf[1] = 'f'; break;
324 if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
325 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
328 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
335 if ( max && (wrote + chsize > max) ) {
337 } else if (chsize > 1) {
338 sv_catpvn(dsv, octbuf, chsize);
341 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
342 128-255 can be appended raw to the dsv. If dsv happens to be
343 UTF-8 then we need catpvf to upgrade them for us.
344 Or add a new API call sv_catpvc(). Think about that name, and
345 how to keep it clear that it's unlike the s of catpvs, which is
346 really an array octets, not a string. */
347 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
350 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
358 =for apidoc pv_pretty
360 Converts a string into something presentable, handling escaping via
361 pv_escape() and supporting quoting and ellipses.
363 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
364 double quoted with any double quotes in the string escaped. Otherwise
365 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
368 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
369 string were output then an ellipsis C<...> will be appended to the
370 string. Note that this happens AFTER it has been quoted.
372 If start_color is non-null then it will be inserted after the opening
373 quote (if there is one) but before the escaped text. If end_color
374 is non-null then it will be inserted after the escaped text but before
375 any quotes or ellipses.
377 Returns a pointer to the prettified text as held by dsv.
383 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
384 const STRLEN max, char const * const start_color, char const * const end_color,
387 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
390 PERL_ARGS_ASSERT_PV_PRETTY;
392 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
393 /* This won't alter the UTF-8 flag */
398 sv_catpvs(dsv, "\"");
399 else if ( flags & PERL_PV_PRETTY_LTGT )
402 if ( start_color != NULL )
403 sv_catpv(dsv, start_color);
405 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
407 if ( end_color != NULL )
408 sv_catpv(dsv, end_color);
411 sv_catpvs( dsv, "\"");
412 else if ( flags & PERL_PV_PRETTY_LTGT )
415 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
416 sv_catpvs(dsv, "...");
422 =for apidoc pv_display
426 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
428 except that an additional "\0" will be appended to the string when
429 len > cur and pv[cur] is "\0".
431 Note that the final string may be up to 7 chars longer than pvlim.
437 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
439 PERL_ARGS_ASSERT_PV_DISPLAY;
441 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
442 if (len > cur && pv[cur] == '\0')
443 sv_catpvs( dsv, "\\0");
448 Perl_sv_peek(pTHX_ SV *sv)
451 SV * const t = sv_newmortal();
461 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
465 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
466 if (sv == &PL_sv_undef) {
467 sv_catpv(t, "SV_UNDEF");
468 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
469 SVs_GMG|SVs_SMG|SVs_RMG)) &&
473 else if (sv == &PL_sv_no) {
474 sv_catpv(t, "SV_NO");
475 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
476 SVs_GMG|SVs_SMG|SVs_RMG)) &&
477 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
483 else if (sv == &PL_sv_yes) {
484 sv_catpv(t, "SV_YES");
485 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
486 SVs_GMG|SVs_SMG|SVs_RMG)) &&
487 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
490 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
495 sv_catpv(t, "SV_PLACEHOLDER");
496 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
497 SVs_GMG|SVs_SMG|SVs_RMG)) &&
503 else if (SvREFCNT(sv) == 0) {
507 else if (DEBUG_R_TEST_) {
510 /* is this SV on the tmps stack? */
511 for (ix=PL_tmps_ix; ix>=0; ix--) {
512 if (PL_tmps_stack[ix] == sv) {
517 if (SvREFCNT(sv) > 1)
518 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
526 if (SvCUR(t) + unref > 10) {
527 SvCUR_set(t, unref + 3);
536 if (type == SVt_PVCV) {
537 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
539 } else if (type < SVt_LAST) {
540 sv_catpv(t, svshorttypenames[type]);
542 if (type == SVt_NULL)
545 sv_catpv(t, "FREED");
550 if (!SvPVX_const(sv))
551 sv_catpv(t, "(null)");
553 SV * const tmp = newSVpvs("");
557 SvOOK_offset(sv, delta);
558 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
560 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
562 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
563 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
568 else if (SvNOKp(sv)) {
569 STORE_NUMERIC_LOCAL_SET_STANDARD();
570 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
571 RESTORE_NUMERIC_LOCAL();
573 else if (SvIOKp(sv)) {
575 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
577 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
585 if (PL_tainting && SvTAINTED(sv))
586 sv_catpv(t, " [tainted]");
587 return SvPV_nolen(t);
591 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
595 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
598 Perl_dump_indent(aTHX_ level, file, "{}\n");
601 Perl_dump_indent(aTHX_ level, file, "{\n");
603 if (pm->op_pmflags & PMf_ONCE)
608 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
609 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
610 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
612 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
613 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
614 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
615 op_dump(pm->op_pmreplrootu.op_pmreplroot);
617 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
618 SV * const tmpsv = pm_description(pm);
619 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
623 Perl_dump_indent(aTHX_ level-1, file, "}\n");
626 const struct flag_to_name pmflags_flags_names[] = {
627 {PMf_CONST, ",CONST"},
629 {PMf_GLOBAL, ",GLOBAL"},
630 {PMf_CONTINUE, ",CONTINUE"},
631 {PMf_RETAINT, ",RETAINT"},
633 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
637 S_pm_description(pTHX_ const PMOP *pm)
639 SV * const desc = newSVpvs("");
640 const REGEXP * const regex = PM_GETRE(pm);
641 const U32 pmflags = pm->op_pmflags;
643 PERL_ARGS_ASSERT_PM_DESCRIPTION;
645 if (pmflags & PMf_ONCE)
646 sv_catpv(desc, ",ONCE");
648 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
649 sv_catpv(desc, ":USED");
651 if (pmflags & PMf_USED)
652 sv_catpv(desc, ":USED");
656 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
657 sv_catpv(desc, ",TAINTED");
658 if (RX_CHECK_SUBSTR(regex)) {
659 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
660 sv_catpv(desc, ",SCANFIRST");
661 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
662 sv_catpv(desc, ",ALL");
664 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
665 sv_catpv(desc, ",SKIPWHITE");
668 append_flags(desc, pmflags, pmflags_flags_names);
673 Perl_pmop_dump(pTHX_ PMOP *pm)
675 do_pmop_dump(0, Perl_debug_log, pm);
678 /* An op sequencer. We visit the ops in the order they're to execute. */
681 S_sequence(pTHX_ register const OP *o)
684 const OP *oldop = NULL;
697 for (; o; o = o->op_next) {
699 SV * const op = newSVuv(PTR2UV(o));
700 const char * const key = SvPV_const(op, len);
702 if (hv_exists(Sequence, key, len))
705 switch (o->op_type) {
707 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
708 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
717 if (oldop && o->op_next)
724 if (oldop && o->op_next)
726 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
739 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
740 sequence_tail(cLOGOPo->op_other);
745 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
746 sequence_tail(cLOOPo->op_redoop);
747 sequence_tail(cLOOPo->op_nextop);
748 sequence_tail(cLOOPo->op_lastop);
752 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
753 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
762 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
770 S_sequence_tail(pTHX_ const OP *o)
772 while (o && (o->op_type == OP_NULL))
778 S_sequence_num(pTHX_ const OP *o)
786 op = newSVuv(PTR2UV(o));
787 key = SvPV_const(op, len);
788 seq = hv_fetch(Sequence, key, len, 0);
789 return seq ? SvUV(*seq): 0;
792 const struct flag_to_name op_flags_names[] = {
794 {OPf_PARENS, ",PARENS"},
797 {OPf_STACKED, ",STACKED"},
798 {OPf_SPECIAL, ",SPECIAL"}
801 const struct flag_to_name op_trans_names[] = {
802 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
803 {OPpTRANS_TO_UTF, ",TO_UTF"},
804 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
805 {OPpTRANS_SQUASH, ",SQUASH"},
806 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
807 {OPpTRANS_GROWS, ",GROWS"},
808 {OPpTRANS_DELETE, ",DELETE"}
811 const struct flag_to_name op_entersub_names[] = {
812 {OPpENTERSUB_DB, ",DB"},
813 {OPpENTERSUB_HASTARG, ",HASTARG"},
814 {OPpENTERSUB_NOMOD, ",NOMOD"},
815 {OPpENTERSUB_AMPER, ",AMPER"},
816 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
817 {OPpENTERSUB_INARGS, ",INARGS"}
820 const struct flag_to_name op_const_names[] = {
821 {OPpCONST_NOVER, ",NOVER"},
822 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
823 {OPpCONST_STRICT, ",STRICT"},
824 {OPpCONST_ENTERED, ",ENTERED"},
825 {OPpCONST_ARYBASE, ",ARYBASE"},
826 {OPpCONST_BARE, ",BARE"},
827 {OPpCONST_WARNING, ",WARNING"}
830 const struct flag_to_name op_sort_names[] = {
831 {OPpSORT_NUMERIC, ",NUMERIC"},
832 {OPpSORT_INTEGER, ",INTEGER"},
833 {OPpSORT_REVERSE, ",REVERSE"},
834 {OPpSORT_INPLACE, ",INPLACE"},
835 {OPpSORT_DESCEND, ",DESCEND"},
836 {OPpSORT_QSORT, ",QSORT"},
837 {OPpSORT_STABLE, ",STABLE"}
840 const struct flag_to_name op_open_names[] = {
841 {OPpOPEN_IN_RAW, ",IN_RAW"},
842 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
843 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
844 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
847 const struct flag_to_name op_exit_names[] = {
848 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
849 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
852 #define OP_PRIVATE_ONCE(op, flag, name) \
853 const struct flag_to_name CAT2(op, _names)[] = { \
857 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
858 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
859 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
860 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
861 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
862 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
863 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
864 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
865 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
866 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
867 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
868 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
870 struct op_private_by_op {
873 const struct flag_to_name *start;
876 const struct op_private_by_op op_private_names[] = {
877 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
878 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
879 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
880 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
881 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
882 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
883 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
884 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
885 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
886 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
887 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
888 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
889 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
890 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
891 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
892 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
893 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
894 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
895 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
896 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
897 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
901 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
902 const struct op_private_by_op *start = op_private_names;
903 const struct op_private_by_op *const end
904 = op_private_names + C_ARRAY_LENGTH(op_private_names);
906 /* This is a linear search, but no worse than the code that it replaced.
907 It's debugging code - size is more important than speed. */
909 if (optype == start->op_type) {
910 S_append_flags(aTHX_ tmpsv, op_private, start->start,
911 start->start + start->len);
914 } while (++start < end);
919 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
923 const OPCODE optype = o->op_type;
925 PERL_ARGS_ASSERT_DO_OP_DUMP;
928 Perl_dump_indent(aTHX_ level, file, "{\n");
930 seq = sequence_num(o);
932 PerlIO_printf(file, "%-4"UVuf, seq);
934 PerlIO_printf(file, " ");
936 "%*sTYPE = %s ===> ",
937 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
939 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
940 sequence_num(o->op_next));
942 PerlIO_printf(file, "DONE\n");
944 if (optype == OP_NULL) {
945 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
946 if (o->op_targ == OP_NEXTSTATE) {
948 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
950 if (CopSTASHPV(cCOPo))
951 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
954 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
959 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
962 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
964 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
965 SV * const tmpsv = newSVpvs("");
966 switch (o->op_flags & OPf_WANT) {
968 sv_catpv(tmpsv, ",VOID");
970 case OPf_WANT_SCALAR:
971 sv_catpv(tmpsv, ",SCALAR");
974 sv_catpv(tmpsv, ",LIST");
977 sv_catpv(tmpsv, ",UNKNOWN");
980 append_flags(tmpsv, o->op_flags, op_flags_names);
982 sv_catpv(tmpsv, ",LATEFREE");
984 sv_catpv(tmpsv, ",LATEFREED");
986 sv_catpv(tmpsv, ",ATTACHED");
987 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
991 SV * const tmpsv = newSVpvs("");
992 if (PL_opargs[optype] & OA_TARGLEX) {
993 if (o->op_private & OPpTARGET_MY)
994 sv_catpv(tmpsv, ",TARGET_MY");
996 else if (optype == OP_ENTERSUB ||
997 optype == OP_RV2SV ||
999 optype == OP_RV2AV ||
1000 optype == OP_RV2HV ||
1001 optype == OP_RV2GV ||
1002 optype == OP_AELEM ||
1003 optype == OP_HELEM )
1005 if (optype == OP_ENTERSUB) {
1006 append_flags(tmpsv, o->op_private, op_entersub_names);
1009 switch (o->op_private & OPpDEREF) {
1011 sv_catpv(tmpsv, ",SV");
1014 sv_catpv(tmpsv, ",AV");
1017 sv_catpv(tmpsv, ",HV");
1020 if (o->op_private & OPpMAYBE_LVSUB)
1021 sv_catpv(tmpsv, ",MAYBE_LVSUB");
1024 if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
1025 && (o->op_private & OPpDEREFed))
1026 sv_catpv(tmpsv, ",DEREFed");
1028 if (optype == OP_AELEM || optype == OP_HELEM) {
1029 if (o->op_private & OPpLVAL_DEFER)
1030 sv_catpv(tmpsv, ",LVAL_DEFER");
1033 if (o->op_private & HINT_STRICT_REFS)
1034 sv_catpv(tmpsv, ",STRICT_REFS");
1035 if (o->op_private & OPpOUR_INTRO)
1036 sv_catpv(tmpsv, ",OUR_INTRO");
1039 else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
1041 else if (PL_check[optype] != Perl_ck_ftst) {
1042 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1043 sv_catpv(tmpsv, ",FT_ACCESS");
1044 if (o->op_private & OPpFT_STACKED)
1045 sv_catpv(tmpsv, ",FT_STACKED");
1047 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1048 sv_catpv(tmpsv, ",INTRO");
1050 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1051 SvREFCNT_dec(tmpsv);
1055 if (PL_madskills && o->op_madprop) {
1056 SV * const tmpsv = newSVpvs("");
1057 MADPROP* mp = o->op_madprop;
1058 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1061 const char tmp = mp->mad_key;
1062 sv_setpvs(tmpsv,"'");
1064 sv_catpvn(tmpsv, &tmp, 1);
1065 sv_catpv(tmpsv, "'=");
1066 switch (mp->mad_type) {
1068 sv_catpv(tmpsv, "NULL");
1069 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1072 sv_catpv(tmpsv, "<");
1073 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1074 sv_catpv(tmpsv, ">");
1075 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1078 if ((OP*)mp->mad_val) {
1079 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1080 do_op_dump(level, file, (OP*)mp->mad_val);
1084 sv_catpv(tmpsv, "(UNK)");
1085 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1091 Perl_dump_indent(aTHX_ level, file, "}\n");
1093 SvREFCNT_dec(tmpsv);
1102 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1104 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1105 if (cSVOPo->op_sv) {
1106 SV * const tmpsv = newSV(0);
1110 /* FIXME - is this making unwarranted assumptions about the
1111 UTF-8 cleanliness of the dump file handle? */
1114 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1115 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1116 SvPV_nolen_const(tmpsv));
1120 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1126 case OP_METHOD_NAMED:
1127 #ifndef USE_ITHREADS
1128 /* with ITHREADS, consts are stored in the pad, and the right pad
1129 * may not be active here, so skip */
1130 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1136 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1137 (UV)CopLINE(cCOPo));
1138 if (CopSTASHPV(cCOPo))
1139 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1141 if (CopLABEL(cCOPo))
1142 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1146 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1147 if (cLOOPo->op_redoop)
1148 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1150 PerlIO_printf(file, "DONE\n");
1151 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1152 if (cLOOPo->op_nextop)
1153 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1155 PerlIO_printf(file, "DONE\n");
1156 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1157 if (cLOOPo->op_lastop)
1158 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1160 PerlIO_printf(file, "DONE\n");
1168 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1169 if (cLOGOPo->op_other)
1170 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1172 PerlIO_printf(file, "DONE\n");
1178 do_pmop_dump(level, file, cPMOPo);
1186 if (o->op_private & OPpREFCOUNTED)
1187 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1192 if (o->op_flags & OPf_KIDS) {
1194 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1195 do_op_dump(level, file, kid);
1197 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1201 Perl_op_dump(pTHX_ const OP *o)
1203 PERL_ARGS_ASSERT_OP_DUMP;
1204 do_op_dump(0, Perl_debug_log, o);
1208 Perl_gv_dump(pTHX_ GV *gv)
1212 PERL_ARGS_ASSERT_GV_DUMP;
1215 PerlIO_printf(Perl_debug_log, "{}\n");
1218 sv = sv_newmortal();
1219 PerlIO_printf(Perl_debug_log, "{\n");
1220 gv_fullname3(sv, gv, NULL);
1221 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1222 if (gv != GvEGV(gv)) {
1223 gv_efullname3(sv, GvEGV(gv), NULL);
1224 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1226 PerlIO_putc(Perl_debug_log, '\n');
1227 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1231 /* map magic types to the symbolic names
1232 * (with the PERL_MAGIC_ prefixed stripped)
1235 static const struct { const char type; const char *name; } magic_names[] = {
1236 #include "mg_names.c"
1237 /* this null string terminates the list */
1242 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1244 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1246 for (; mg; mg = mg->mg_moremagic) {
1247 Perl_dump_indent(aTHX_ level, file,
1248 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1249 if (mg->mg_virtual) {
1250 const MGVTBL * const v = mg->mg_virtual;
1251 if (v >= PL_magic_vtables
1252 && v < PL_magic_vtables + magic_vtable_max) {
1253 const U32 i = v - PL_magic_vtables;
1254 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1257 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1260 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1263 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1267 const char *name = NULL;
1268 for (n = 0; magic_names[n].name; n++) {
1269 if (mg->mg_type == magic_names[n].type) {
1270 name = magic_names[n].name;
1275 Perl_dump_indent(aTHX_ level, file,
1276 " MG_TYPE = PERL_MAGIC_%s\n", name);
1278 Perl_dump_indent(aTHX_ level, file,
1279 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1283 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1284 if (mg->mg_type == PERL_MAGIC_envelem &&
1285 mg->mg_flags & MGf_TAINTEDDIR)
1286 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1287 if (mg->mg_type == PERL_MAGIC_regex_global &&
1288 mg->mg_flags & MGf_MINMATCH)
1289 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1290 if (mg->mg_flags & MGf_REFCOUNTED)
1291 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1292 if (mg->mg_flags & MGf_GSKIP)
1293 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1294 if (mg->mg_flags & MGf_COPY)
1295 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1296 if (mg->mg_flags & MGf_DUP)
1297 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1298 if (mg->mg_flags & MGf_LOCAL)
1299 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1302 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1303 PTR2UV(mg->mg_obj));
1304 if (mg->mg_type == PERL_MAGIC_qr) {
1305 REGEXP* const re = (REGEXP *)mg->mg_obj;
1306 SV * const dsv = sv_newmortal();
1307 const char * const s
1308 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1310 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1311 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1313 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1314 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1317 if (mg->mg_flags & MGf_REFCOUNTED)
1318 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1321 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1323 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1324 if (mg->mg_len >= 0) {
1325 if (mg->mg_type != PERL_MAGIC_utf8) {
1326 SV * const sv = newSVpvs("");
1327 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1331 else if (mg->mg_len == HEf_SVKEY) {
1332 PerlIO_puts(file, " => HEf_SVKEY\n");
1333 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1334 maxnest, dumpops, pvlim); /* MG is already +1 */
1337 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1342 " does not know how to handle this MG_LEN"
1344 PerlIO_putc(file, '\n');
1346 if (mg->mg_type == PERL_MAGIC_utf8) {
1347 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1350 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1351 Perl_dump_indent(aTHX_ level, file,
1352 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1355 (UV)cache[i * 2 + 1]);
1362 Perl_magic_dump(pTHX_ const MAGIC *mg)
1364 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1368 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1372 PERL_ARGS_ASSERT_DO_HV_DUMP;
1374 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1375 if (sv && (hvname = HvNAME_get(sv)))
1377 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1378 name which quite legally could contain insane things like tabs, newlines, nulls or
1379 other scary crap - this should produce sane results - except maybe for unicode package
1380 names - but we will wait for someone to file a bug on that - demerphq */
1381 SV * const tmpsv = newSVpvs("");
1382 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1385 PerlIO_putc(file, '\n');
1389 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1391 PERL_ARGS_ASSERT_DO_GV_DUMP;
1393 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1394 if (sv && GvNAME(sv))
1395 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1397 PerlIO_putc(file, '\n');
1401 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1403 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1405 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1406 if (sv && GvNAME(sv)) {
1408 PerlIO_printf(file, "\t\"");
1409 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1410 PerlIO_printf(file, "%s\" :: \"", hvname);
1411 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1414 PerlIO_putc(file, '\n');
1417 const struct flag_to_name first_sv_flags_names[] = {
1418 {SVs_TEMP, "TEMP,"},
1419 {SVs_OBJECT, "OBJECT,"},
1428 const struct flag_to_name second_sv_flags_names[] = {
1430 {SVf_FAKE, "FAKE,"},
1431 {SVf_READONLY, "READONLY,"},
1432 {SVf_BREAK, "BREAK,"},
1433 {SVf_AMAGIC, "OVERLOAD,"},
1439 const struct flag_to_name cv_flags_names[] = {
1440 {CVf_ANON, "ANON,"},
1441 {CVf_UNIQUE, "UNIQUE,"},
1442 {CVf_CLONE, "CLONE,"},
1443 {CVf_CLONED, "CLONED,"},
1444 {CVf_CONST, "CONST,"},
1445 {CVf_NODEBUG, "NODEBUG,"},
1446 {CVf_LVALUE, "LVALUE,"},
1447 {CVf_METHOD, "METHOD,"},
1448 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1449 {CVf_CVGV_RC, "CVGV_RC,"},
1450 {CVf_ISXSUB, "ISXSUB,"}
1453 const struct flag_to_name hv_flags_names[] = {
1454 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1455 {SVphv_LAZYDEL, "LAZYDEL,"},
1456 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1457 {SVphv_REHASH, "REHASH,"},
1458 {SVphv_CLONEABLE, "CLONEABLE,"}
1461 const struct flag_to_name gp_flags_names[] = {
1462 {GVf_INTRO, "INTRO,"},
1463 {GVf_MULTI, "MULTI,"},
1464 {GVf_ASSUMECV, "ASSUMECV,"},
1465 {GVf_IN_PAD, "IN_PAD,"}
1468 const struct flag_to_name gp_flags_imported_names[] = {
1469 {GVf_IMPORTED_SV, " SV"},
1470 {GVf_IMPORTED_AV, " AV"},
1471 {GVf_IMPORTED_HV, " HV"},
1472 {GVf_IMPORTED_CV, " CV"},
1475 const struct flag_to_name regexp_flags_names[] = {
1476 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1477 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1478 {RXf_PMf_FOLD, "PMf_FOLD,"},
1479 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1480 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1481 {RXf_ANCH_BOL, "ANCH_BOL,"},
1482 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1483 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1484 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1485 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1486 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1487 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1488 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1489 {RXf_CANY_SEEN, "CANY_SEEN,"},
1490 {RXf_NOSCAN, "NOSCAN,"},
1491 {RXf_CHECK_ALL, "CHECK_ALL,"},
1492 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1493 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1494 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1495 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1496 {RXf_SPLIT, "SPLIT,"},
1497 {RXf_COPY_DONE, "COPY_DONE,"},
1498 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1499 {RXf_TAINTED, "TAINTED,"},
1500 {RXf_START_ONLY, "START_ONLY,"},
1501 {RXf_SKIPWHITE, "SKIPWHITE,"},
1502 {RXf_WHITE, "WHITE,"},
1503 {RXf_NULL, "NULL,"},
1507 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1515 PERL_ARGS_ASSERT_DO_SV_DUMP;
1518 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1522 flags = SvFLAGS(sv);
1525 /* process general SV flags */
1527 d = Perl_newSVpvf(aTHX_
1528 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1529 PTR2UV(SvANY(sv)), PTR2UV(sv),
1530 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1531 (int)(PL_dumpindent*level), "");
1533 if (!((flags & SVpad_NAME) == SVpad_NAME
1534 && (type == SVt_PVMG || type == SVt_PVNV))) {
1535 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1537 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1538 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1539 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1541 append_flags(d, flags, first_sv_flags_names);
1542 if (flags & SVf_ROK) {
1543 sv_catpv(d, "ROK,");
1544 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1546 append_flags(d, flags, second_sv_flags_names);
1547 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1548 if (SvPCS_IMPORTED(sv))
1549 sv_catpv(d, "PCS_IMPORTED,");
1551 sv_catpv(d, "SCREAM,");
1554 /* process type-specific SV flags */
1559 append_flags(d, CvFLAGS(sv), cv_flags_names);
1562 append_flags(d, flags, hv_flags_names);
1566 if (isGV_with_GP(sv)) {
1567 append_flags(d, GvFLAGS(sv), gp_flags_names);
1569 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1570 sv_catpv(d, "IMPORT");
1571 if (GvIMPORTED(sv) == GVf_IMPORTED)
1572 sv_catpv(d, "ALL,");
1575 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1582 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1583 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1586 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1587 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1588 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1589 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1592 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1597 /* SVphv_SHAREKEYS is also 0x20000000 */
1598 if ((type != SVt_PVHV) && SvUTF8(sv))
1599 sv_catpv(d, "UTF8");
1601 if (*(SvEND(d) - 1) == ',') {
1602 SvCUR_set(d, SvCUR(d) - 1);
1603 SvPVX(d)[SvCUR(d)] = '\0';
1608 /* dump initial SV details */
1610 #ifdef DEBUG_LEAKING_SCALARS
1611 Perl_dump_indent(aTHX_ level, file,
1612 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1613 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1615 sv->sv_debug_inpad ? "for" : "by",
1616 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1617 PTR2UV(sv->sv_debug_parent),
1621 Perl_dump_indent(aTHX_ level, file, "SV = ");
1625 if (type < SVt_LAST) {
1626 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1628 if (type == SVt_NULL) {
1633 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1638 /* Dump general SV fields */
1640 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1641 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1642 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1643 || (type == SVt_IV && !SvROK(sv))) {
1645 #ifdef PERL_OLD_COPY_ON_WRITE
1649 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1651 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1652 #ifdef PERL_OLD_COPY_ON_WRITE
1653 if (SvIsCOW_shared_hash(sv))
1654 PerlIO_printf(file, " (HASH)");
1655 else if (SvIsCOW_normal(sv))
1656 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1658 PerlIO_putc(file, '\n');
1661 if ((type == SVt_PVNV || type == SVt_PVMG)
1662 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1663 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1664 (UV) COP_SEQ_RANGE_LOW(sv));
1665 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1666 (UV) COP_SEQ_RANGE_HIGH(sv));
1667 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1668 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1669 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1670 || type == SVt_NV) {
1671 STORE_NUMERIC_LOCAL_SET_STANDARD();
1672 /* %Vg doesn't work? --jhi */
1673 #ifdef USE_LONG_DOUBLE
1674 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1676 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1678 RESTORE_NUMERIC_LOCAL();
1682 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1684 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1687 if (type < SVt_PV) {
1692 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1693 if (SvPVX_const(sv)) {
1696 SvOOK_offset(sv, delta);
1697 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1702 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1704 PerlIO_printf(file, "( %s . ) ",
1705 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1708 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1709 if (SvUTF8(sv)) /* the 6? \x{....} */
1710 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1711 PerlIO_printf(file, "\n");
1712 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1713 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1716 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1719 if (type >= SVt_PVMG) {
1720 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1721 HV * const ost = SvOURSTASH(sv);
1723 do_hv_dump(level, file, " OURSTASH", ost);
1726 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1729 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1731 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1732 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1733 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1734 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1738 /* Dump type-specific SV fields */
1742 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1743 if (AvARRAY(sv) != AvALLOC(sv)) {
1744 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1745 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1748 PerlIO_putc(file, '\n');
1749 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1750 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1751 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1753 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1754 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1755 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1756 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1757 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1759 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1760 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1762 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1764 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1769 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1770 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1771 /* Show distribution of HEs in the ARRAY */
1773 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1776 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1777 NV theoret, sum = 0;
1779 PerlIO_printf(file, " (");
1780 Zero(freq, FREQ_MAX + 1, int);
1781 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1784 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1786 if (count > FREQ_MAX)
1792 for (i = 0; i <= max; i++) {
1794 PerlIO_printf(file, "%d%s:%d", i,
1795 (i == FREQ_MAX) ? "+" : "",
1798 PerlIO_printf(file, ", ");
1801 PerlIO_putc(file, ')');
1802 /* The "quality" of a hash is defined as the total number of
1803 comparisons needed to access every element once, relative
1804 to the expected number needed for a random hash.
1806 The total number of comparisons is equal to the sum of
1807 the squares of the number of entries in each bucket.
1808 For a random hash of n keys into k buckets, the expected
1813 for (i = max; i > 0; i--) { /* Precision: count down. */
1814 sum += freq[i] * i * i;
1816 while ((keys = keys >> 1))
1818 theoret = HvUSEDKEYS(sv);
1819 theoret += theoret * (theoret-1)/pow2;
1820 PerlIO_putc(file, '\n');
1821 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1823 PerlIO_putc(file, '\n');
1824 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1825 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1826 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1827 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1828 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1830 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1831 if (mg && mg->mg_obj) {
1832 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1836 const char * const hvname = HvNAME_get(sv);
1838 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1842 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1843 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1844 if (HvAUX(sv)->xhv_name_count)
1845 Perl_dump_indent(aTHX_
1846 level, file, " NAMECOUNT = %"IVdf"\n",
1847 (IV)HvAUX(sv)->xhv_name_count
1849 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1850 const I32 count = HvAUX(sv)->xhv_name_count;
1852 SV * const names = newSVpvs_flags("", SVs_TEMP);
1853 /* The starting point is the first element if count is
1854 positive and the second element if count is negative. */
1855 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1856 + (count < 0 ? 1 : 0);
1857 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1858 + (count < 0 ? -count : count);
1859 while (hekp < endp) {
1861 sv_catpvs(names, ", \"");
1862 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1863 sv_catpvs(names, "\"");
1865 /* This should never happen. */
1866 sv_catpvs(names, ", (null)");
1870 Perl_dump_indent(aTHX_
1871 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1875 Perl_dump_indent(aTHX_
1876 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1880 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1882 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1886 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1887 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1888 (int)meta->mro_which->length,
1889 meta->mro_which->name,
1890 PTR2UV(meta->mro_which));
1891 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1892 (UV)meta->cache_gen);
1893 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1895 if (meta->mro_linear_all) {
1896 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1897 PTR2UV(meta->mro_linear_all));
1898 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1901 if (meta->mro_linear_current) {
1902 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1903 PTR2UV(meta->mro_linear_current));
1904 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1907 if (meta->mro_nextmethod) {
1908 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1909 PTR2UV(meta->mro_nextmethod));
1910 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1914 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1916 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1921 if (nest < maxnest) {
1922 HV * const hv = MUTABLE_HV(sv);
1927 int count = maxnest - nest;
1928 for (i=0; i <= HvMAX(hv); i++) {
1929 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1936 if (count-- <= 0) goto DONEHV;
1939 keysv = hv_iterkeysv(he);
1940 keypv = SvPV_const(keysv, len);
1943 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1945 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1946 if (HvEITER_get(hv) == he)
1947 PerlIO_printf(file, "[CURRENT] ");
1949 PerlIO_printf(file, "[REHASH] ");
1950 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1951 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1962 const char *const proto = SvPV_const(sv, len);
1963 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1968 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1969 if (!CvISXSUB(sv)) {
1971 Perl_dump_indent(aTHX_ level, file,
1972 " START = 0x%"UVxf" ===> %"IVdf"\n",
1973 PTR2UV(CvSTART(sv)),
1974 (IV)sequence_num(CvSTART(sv)));
1976 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1977 PTR2UV(CvROOT(sv)));
1978 if (CvROOT(sv) && dumpops) {
1979 do_op_dump(level+1, file, CvROOT(sv));
1982 SV * const constant = cv_const_sv((const CV *)sv);
1984 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1987 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1989 PTR2UV(CvXSUBANY(sv).any_ptr));
1990 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1993 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1994 (IV)CvXSUBANY(sv).any_i32);
1997 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1998 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1999 if (type == SVt_PVCV)
2000 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2001 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2002 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2003 if (type == SVt_PVFM)
2004 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
2005 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2006 if (nest < maxnest) {
2007 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2010 const CV * const outside = CvOUTSIDE(sv);
2011 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2014 : CvANON(outside) ? "ANON"
2015 : (outside == PL_main_cv) ? "MAIN"
2016 : CvUNIQUE(outside) ? "UNIQUE"
2017 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2019 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2020 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2025 if (type == SVt_PVLV) {
2026 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2027 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2028 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2029 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2030 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2031 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2034 if (!isGV_with_GP(sv))
2036 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2037 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2038 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2039 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2042 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2043 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2044 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2045 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2046 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2047 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2048 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2049 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2050 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2051 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2052 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2053 do_gv_dump (level, file, " EGV", GvEGV(sv));
2056 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2057 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2058 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2059 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2060 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2061 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2062 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2064 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2065 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2066 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2068 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2069 PTR2UV(IoTOP_GV(sv)));
2070 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2071 maxnest, dumpops, pvlim);
2073 /* Source filters hide things that are not GVs in these three, so let's
2074 be careful out there. */
2076 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2077 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2078 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2080 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2081 PTR2UV(IoFMT_GV(sv)));
2082 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2083 maxnest, dumpops, pvlim);
2085 if (IoBOTTOM_NAME(sv))
2086 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2087 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2088 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2090 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2091 PTR2UV(IoBOTTOM_GV(sv)));
2092 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2093 maxnest, dumpops, pvlim);
2095 if (isPRINT(IoTYPE(sv)))
2096 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2098 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2099 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2103 struct regexp * const r = (struct regexp *)SvANY(sv);
2104 flags = RX_EXTFLAGS((REGEXP*)sv);
2106 append_flags(d, flags, regexp_flags_names);
2107 if (*(SvEND(d) - 1) == ',') {
2108 SvCUR_set(d, SvCUR(d) - 1);
2109 SvPVX(d)[SvCUR(d)] = '\0';
2111 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2112 (UV)flags, SvPVX_const(d));
2113 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2115 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2117 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2118 (UV)(r->lastparen));
2119 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2120 (UV)(r->lastcloseparen));
2121 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2123 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2124 (IV)(r->minlenret));
2125 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2127 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2128 (UV)(r->pre_prefix));
2129 Perl_dump_indent(aTHX_ level, file, " SEEN_EVALS = %"UVuf"\n",
2130 (UV)(r->seen_evals));
2131 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2134 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2136 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2138 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2139 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2141 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2142 PTR2UV(r->mother_re));
2143 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2144 PTR2UV(r->paren_names));
2145 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2146 PTR2UV(r->substrs));
2147 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2148 PTR2UV(r->pprivate));
2149 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2151 #ifdef PERL_OLD_COPY_ON_WRITE
2152 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2153 PTR2UV(r->saved_copy));
2162 Perl_sv_dump(pTHX_ SV *sv)
2166 PERL_ARGS_ASSERT_SV_DUMP;
2169 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2171 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2175 Perl_runops_debug(pTHX)
2179 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2183 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2186 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2187 PerlIO_printf(Perl_debug_log,
2188 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2189 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2190 PTR2UV(*PL_watchaddr));
2191 if (DEBUG_s_TEST_) {
2192 if (DEBUG_v_TEST_) {
2193 PerlIO_printf(Perl_debug_log, "\n");
2201 if (DEBUG_t_TEST_) debop(PL_op);
2202 if (DEBUG_P_TEST_) debprof(PL_op);
2204 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2205 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2212 Perl_debop(pTHX_ const OP *o)
2216 PERL_ARGS_ASSERT_DEBOP;
2218 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2221 Perl_deb(aTHX_ "%s", OP_NAME(o));
2222 switch (o->op_type) {
2225 /* With ITHREADS, consts are stored in the pad, and the right pad
2226 * may not be active here, so check.
2227 * Looks like only during compiling the pads are illegal.
2230 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2232 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2237 SV * const sv = newSV(0);
2239 /* FIXME - is this making unwarranted assumptions about the
2240 UTF-8 cleanliness of the dump file handle? */
2243 gv_fullname3(sv, cGVOPo_gv, NULL);
2244 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2248 PerlIO_printf(Perl_debug_log, "(NULL)");
2254 /* print the lexical's name */
2255 CV * const cv = deb_curcv(cxstack_ix);
2258 AV * const padlist = CvPADLIST(cv);
2259 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2260 sv = *av_fetch(comppad, o->op_targ, FALSE);
2264 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2266 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2272 PerlIO_printf(Perl_debug_log, "\n");
2277 S_deb_curcv(pTHX_ const I32 ix)
2280 const PERL_CONTEXT * const cx = &cxstack[ix];
2281 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2282 return cx->blk_sub.cv;
2283 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2285 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2290 return deb_curcv(ix - 1);
2294 Perl_watch(pTHX_ char **addr)
2298 PERL_ARGS_ASSERT_WATCH;
2300 PL_watchaddr = addr;
2302 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2303 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2307 S_debprof(pTHX_ const OP *o)
2311 PERL_ARGS_ASSERT_DEBPROF;
2313 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2315 if (!PL_profiledata)
2316 Newxz(PL_profiledata, MAXO, U32);
2317 ++PL_profiledata[o->op_type];
2321 Perl_debprofdump(pTHX)
2325 if (!PL_profiledata)
2327 for (i = 0; i < MAXO; i++) {
2328 if (PL_profiledata[i])
2329 PerlIO_printf(Perl_debug_log,
2330 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2337 * XML variants of most of the above routines
2341 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2345 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2347 PerlIO_printf(file, "\n ");
2348 va_start(args, pat);
2349 xmldump_vindent(level, file, pat, &args);
2355 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2358 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2359 va_start(args, pat);
2360 xmldump_vindent(level, file, pat, &args);
2365 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2367 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2369 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2370 PerlIO_vprintf(file, pat, *args);
2374 Perl_xmldump_all(pTHX)
2376 xmldump_all_perl(FALSE);
2380 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2382 PerlIO_setlinebuf(PL_xmlfp);
2384 op_xmldump(PL_main_root);
2385 /* someday we might call this, when it outputs XML: */
2386 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2387 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2388 PerlIO_close(PL_xmlfp);
2393 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2395 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2396 xmldump_packsubs_perl(stash, FALSE);
2400 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2405 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2407 if (!HvARRAY(stash))
2409 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2410 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2411 GV *gv = MUTABLE_GV(HeVAL(entry));
2413 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2416 xmldump_sub_perl(gv, justperl);
2419 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2420 && (hv = GvHV(gv)) && hv != PL_defstash)
2421 xmldump_packsubs_perl(hv, justperl); /* nested package */
2427 Perl_xmldump_sub(pTHX_ const GV *gv)
2429 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2430 xmldump_sub_perl(gv, FALSE);
2434 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2438 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2440 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2443 sv = sv_newmortal();
2444 gv_fullname3(sv, gv, NULL);
2445 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2446 if (CvXSUB(GvCV(gv)))
2447 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2448 PTR2UV(CvXSUB(GvCV(gv))),
2449 (int)CvXSUBANY(GvCV(gv)).any_i32);
2450 else if (CvROOT(GvCV(gv)))
2451 op_xmldump(CvROOT(GvCV(gv)));
2453 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2457 Perl_xmldump_form(pTHX_ const GV *gv)
2459 SV * const sv = sv_newmortal();
2461 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2463 gv_fullname3(sv, gv, NULL);
2464 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2465 if (CvROOT(GvFORM(gv)))
2466 op_xmldump(CvROOT(GvFORM(gv)));
2468 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2472 Perl_xmldump_eval(pTHX)
2474 op_xmldump(PL_eval_root);
2478 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2480 PERL_ARGS_ASSERT_SV_CATXMLSV;
2481 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2485 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2487 PERL_ARGS_ASSERT_SV_CATXMLPV;
2488 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2492 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2495 const char * const e = pv + len;
2496 const char * const start = pv;
2500 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2503 dsvcur = SvCUR(dsv); /* in case we have to restart */
2508 c = utf8_to_uvchr((U8*)pv, &cl);
2510 SvCUR(dsv) = dsvcur;
2575 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2578 sv_catpvs(dsv, "<");
2581 sv_catpvs(dsv, ">");
2584 sv_catpvs(dsv, "&");
2587 sv_catpvs(dsv, """);
2591 if (c < 32 || c > 127) {
2592 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2595 const char string = (char) c;
2596 sv_catpvn(dsv, &string, 1);
2600 if ((c >= 0xD800 && c <= 0xDB7F) ||
2601 (c >= 0xDC00 && c <= 0xDFFF) ||
2602 (c >= 0xFFF0 && c <= 0xFFFF) ||
2604 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2606 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2619 Perl_sv_xmlpeek(pTHX_ SV *sv)
2621 SV * const t = sv_newmortal();
2625 PERL_ARGS_ASSERT_SV_XMLPEEK;
2631 sv_catpv(t, "VOID=\"\"");
2634 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2635 sv_catpv(t, "WILD=\"\"");
2638 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2639 if (sv == &PL_sv_undef) {
2640 sv_catpv(t, "SV_UNDEF=\"1\"");
2641 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2642 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2646 else if (sv == &PL_sv_no) {
2647 sv_catpv(t, "SV_NO=\"1\"");
2648 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2649 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2650 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2651 SVp_POK|SVp_NOK)) &&
2656 else if (sv == &PL_sv_yes) {
2657 sv_catpv(t, "SV_YES=\"1\"");
2658 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2659 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2660 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2661 SVp_POK|SVp_NOK)) &&
2663 SvPVX(sv) && *SvPVX(sv) == '1' &&
2668 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2669 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2670 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2674 sv_catpv(t, " XXX=\"\" ");
2676 else if (SvREFCNT(sv) == 0) {
2677 sv_catpv(t, " refcnt=\"0\"");
2680 else if (DEBUG_R_TEST_) {
2683 /* is this SV on the tmps stack? */
2684 for (ix=PL_tmps_ix; ix>=0; ix--) {
2685 if (PL_tmps_stack[ix] == sv) {
2690 if (SvREFCNT(sv) > 1)
2691 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2694 sv_catpv(t, " DRT=\"<T>\"");
2698 sv_catpv(t, " ROK=\"\"");
2700 switch (SvTYPE(sv)) {
2702 sv_catpv(t, " FREED=\"1\"");
2706 sv_catpv(t, " UNDEF=\"1\"");
2709 sv_catpv(t, " IV=\"");
2712 sv_catpv(t, " NV=\"");
2715 sv_catpv(t, " PV=\"");
2718 sv_catpv(t, " PVIV=\"");
2721 sv_catpv(t, " PVNV=\"");
2724 sv_catpv(t, " PVMG=\"");
2727 sv_catpv(t, " PVLV=\"");
2730 sv_catpv(t, " AV=\"");
2733 sv_catpv(t, " HV=\"");
2737 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2739 sv_catpv(t, " CV=\"()\"");
2742 sv_catpv(t, " GV=\"");
2745 sv_catpv(t, " BIND=\"");
2748 sv_catpv(t, " REGEXP=\"");
2751 sv_catpv(t, " FM=\"");
2754 sv_catpv(t, " IO=\"");
2763 else if (SvNOKp(sv)) {
2764 STORE_NUMERIC_LOCAL_SET_STANDARD();
2765 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2766 RESTORE_NUMERIC_LOCAL();
2768 else if (SvIOKp(sv)) {
2770 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2772 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2781 return SvPV(t, n_a);
2785 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2787 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2790 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2793 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2796 REGEXP *const r = PM_GETRE(pm);
2797 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2798 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2799 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2801 SvREFCNT_dec(tmpsv);
2802 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2803 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2806 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2807 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2808 SV * const tmpsv = pm_description(pm);
2809 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2810 SvREFCNT_dec(tmpsv);
2814 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2815 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2816 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2817 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2818 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2819 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2822 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2826 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2828 do_pmop_xmldump(0, PL_xmlfp, pm);
2832 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2837 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2842 seq = sequence_num(o);
2843 Perl_xmldump_indent(aTHX_ level, file,
2844 "<op_%s seq=\"%"UVuf" -> ",
2849 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2850 sequence_num(o->op_next));
2852 PerlIO_printf(file, "DONE\"");
2855 if (o->op_type == OP_NULL)
2857 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2858 if (o->op_targ == OP_NEXTSTATE)
2861 PerlIO_printf(file, " line=\"%"UVuf"\"",
2862 (UV)CopLINE(cCOPo));
2863 if (CopSTASHPV(cCOPo))
2864 PerlIO_printf(file, " package=\"%s\"",
2866 if (CopLABEL(cCOPo))
2867 PerlIO_printf(file, " label=\"%s\"",
2872 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2875 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2878 SV * const tmpsv = newSVpvs("");
2879 switch (o->op_flags & OPf_WANT) {
2881 sv_catpv(tmpsv, ",VOID");
2883 case OPf_WANT_SCALAR:
2884 sv_catpv(tmpsv, ",SCALAR");
2887 sv_catpv(tmpsv, ",LIST");
2890 sv_catpv(tmpsv, ",UNKNOWN");
2893 if (o->op_flags & OPf_KIDS)
2894 sv_catpv(tmpsv, ",KIDS");
2895 if (o->op_flags & OPf_PARENS)
2896 sv_catpv(tmpsv, ",PARENS");
2897 if (o->op_flags & OPf_STACKED)
2898 sv_catpv(tmpsv, ",STACKED");
2899 if (o->op_flags & OPf_REF)
2900 sv_catpv(tmpsv, ",REF");
2901 if (o->op_flags & OPf_MOD)
2902 sv_catpv(tmpsv, ",MOD");
2903 if (o->op_flags & OPf_SPECIAL)
2904 sv_catpv(tmpsv, ",SPECIAL");
2905 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2906 SvREFCNT_dec(tmpsv);
2908 if (o->op_private) {
2909 SV * const tmpsv = newSVpvs("");
2910 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2911 if (o->op_private & OPpTARGET_MY)
2912 sv_catpv(tmpsv, ",TARGET_MY");
2914 else if (o->op_type == OP_LEAVESUB ||
2915 o->op_type == OP_LEAVE ||
2916 o->op_type == OP_LEAVESUBLV ||
2917 o->op_type == OP_LEAVEWRITE) {
2918 if (o->op_private & OPpREFCOUNTED)
2919 sv_catpv(tmpsv, ",REFCOUNTED");
2921 else if (o->op_type == OP_AASSIGN) {
2922 if (o->op_private & OPpASSIGN_COMMON)
2923 sv_catpv(tmpsv, ",COMMON");
2925 else if (o->op_type == OP_SASSIGN) {
2926 if (o->op_private & OPpASSIGN_BACKWARDS)
2927 sv_catpv(tmpsv, ",BACKWARDS");
2929 else if (o->op_type == OP_TRANS) {
2930 if (o->op_private & OPpTRANS_SQUASH)
2931 sv_catpv(tmpsv, ",SQUASH");
2932 if (o->op_private & OPpTRANS_DELETE)
2933 sv_catpv(tmpsv, ",DELETE");
2934 if (o->op_private & OPpTRANS_COMPLEMENT)
2935 sv_catpv(tmpsv, ",COMPLEMENT");
2936 if (o->op_private & OPpTRANS_IDENTICAL)
2937 sv_catpv(tmpsv, ",IDENTICAL");
2938 if (o->op_private & OPpTRANS_GROWS)
2939 sv_catpv(tmpsv, ",GROWS");
2941 else if (o->op_type == OP_REPEAT) {
2942 if (o->op_private & OPpREPEAT_DOLIST)
2943 sv_catpv(tmpsv, ",DOLIST");
2945 else if (o->op_type == OP_ENTERSUB ||
2946 o->op_type == OP_RV2SV ||
2947 o->op_type == OP_GVSV ||
2948 o->op_type == OP_RV2AV ||
2949 o->op_type == OP_RV2HV ||
2950 o->op_type == OP_RV2GV ||
2951 o->op_type == OP_AELEM ||
2952 o->op_type == OP_HELEM )
2954 if (o->op_type == OP_ENTERSUB) {
2955 if (o->op_private & OPpENTERSUB_AMPER)
2956 sv_catpv(tmpsv, ",AMPER");
2957 if (o->op_private & OPpENTERSUB_DB)
2958 sv_catpv(tmpsv, ",DB");
2959 if (o->op_private & OPpENTERSUB_HASTARG)
2960 sv_catpv(tmpsv, ",HASTARG");
2961 if (o->op_private & OPpENTERSUB_NOPAREN)
2962 sv_catpv(tmpsv, ",NOPAREN");
2963 if (o->op_private & OPpENTERSUB_INARGS)
2964 sv_catpv(tmpsv, ",INARGS");
2965 if (o->op_private & OPpENTERSUB_NOMOD)
2966 sv_catpv(tmpsv, ",NOMOD");
2969 switch (o->op_private & OPpDEREF) {
2971 sv_catpv(tmpsv, ",SV");
2974 sv_catpv(tmpsv, ",AV");
2977 sv_catpv(tmpsv, ",HV");
2980 if (o->op_private & OPpMAYBE_LVSUB)
2981 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2983 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2984 if (o->op_private & OPpLVAL_DEFER)
2985 sv_catpv(tmpsv, ",LVAL_DEFER");
2988 if (o->op_private & HINT_STRICT_REFS)
2989 sv_catpv(tmpsv, ",STRICT_REFS");
2990 if (o->op_private & OPpOUR_INTRO)
2991 sv_catpv(tmpsv, ",OUR_INTRO");
2994 else if (o->op_type == OP_CONST) {
2995 if (o->op_private & OPpCONST_BARE)
2996 sv_catpv(tmpsv, ",BARE");
2997 if (o->op_private & OPpCONST_STRICT)
2998 sv_catpv(tmpsv, ",STRICT");
2999 if (o->op_private & OPpCONST_ARYBASE)
3000 sv_catpv(tmpsv, ",ARYBASE");
3001 if (o->op_private & OPpCONST_WARNING)
3002 sv_catpv(tmpsv, ",WARNING");
3003 if (o->op_private & OPpCONST_ENTERED)
3004 sv_catpv(tmpsv, ",ENTERED");
3006 else if (o->op_type == OP_FLIP) {
3007 if (o->op_private & OPpFLIP_LINENUM)
3008 sv_catpv(tmpsv, ",LINENUM");
3010 else if (o->op_type == OP_FLOP) {
3011 if (o->op_private & OPpFLIP_LINENUM)
3012 sv_catpv(tmpsv, ",LINENUM");
3014 else if (o->op_type == OP_RV2CV) {
3015 if (o->op_private & OPpLVAL_INTRO)
3016 sv_catpv(tmpsv, ",INTRO");
3018 else if (o->op_type == OP_GV) {
3019 if (o->op_private & OPpEARLY_CV)
3020 sv_catpv(tmpsv, ",EARLY_CV");
3022 else if (o->op_type == OP_LIST) {
3023 if (o->op_private & OPpLIST_GUESSED)
3024 sv_catpv(tmpsv, ",GUESSED");
3026 else if (o->op_type == OP_DELETE) {
3027 if (o->op_private & OPpSLICE)
3028 sv_catpv(tmpsv, ",SLICE");
3030 else if (o->op_type == OP_EXISTS) {
3031 if (o->op_private & OPpEXISTS_SUB)
3032 sv_catpv(tmpsv, ",EXISTS_SUB");
3034 else if (o->op_type == OP_SORT) {
3035 if (o->op_private & OPpSORT_NUMERIC)
3036 sv_catpv(tmpsv, ",NUMERIC");
3037 if (o->op_private & OPpSORT_INTEGER)
3038 sv_catpv(tmpsv, ",INTEGER");
3039 if (o->op_private & OPpSORT_REVERSE)
3040 sv_catpv(tmpsv, ",REVERSE");
3042 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
3043 if (o->op_private & OPpOPEN_IN_RAW)
3044 sv_catpv(tmpsv, ",IN_RAW");
3045 if (o->op_private & OPpOPEN_IN_CRLF)
3046 sv_catpv(tmpsv, ",IN_CRLF");
3047 if (o->op_private & OPpOPEN_OUT_RAW)
3048 sv_catpv(tmpsv, ",OUT_RAW");
3049 if (o->op_private & OPpOPEN_OUT_CRLF)
3050 sv_catpv(tmpsv, ",OUT_CRLF");
3052 else if (o->op_type == OP_EXIT) {
3053 if (o->op_private & OPpEXIT_VMSISH)
3054 sv_catpv(tmpsv, ",EXIT_VMSISH");
3055 if (o->op_private & OPpHUSH_VMSISH)
3056 sv_catpv(tmpsv, ",HUSH_VMSISH");
3058 else if (o->op_type == OP_DIE) {
3059 if (o->op_private & OPpHUSH_VMSISH)
3060 sv_catpv(tmpsv, ",HUSH_VMSISH");
3062 else if (PL_check[o->op_type] != Perl_ck_ftst) {
3063 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
3064 sv_catpv(tmpsv, ",FT_ACCESS");
3065 if (o->op_private & OPpFT_STACKED)
3066 sv_catpv(tmpsv, ",FT_STACKED");
3068 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
3069 sv_catpv(tmpsv, ",INTRO");
3071 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
3072 SvREFCNT_dec(tmpsv);
3075 switch (o->op_type) {
3077 if (o->op_flags & OPf_SPECIAL) {
3083 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3085 if (cSVOPo->op_sv) {
3086 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3087 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3093 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3094 s = SvPV(tmpsv1,len);
3095 sv_catxmlpvn(tmpsv2, s, len, 1);
3096 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3100 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3105 case OP_METHOD_NAMED:
3106 #ifndef USE_ITHREADS
3107 /* with ITHREADS, consts are stored in the pad, and the right pad
3108 * may not be active here, so skip */
3109 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3115 PerlIO_printf(file, ">\n");
3117 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3122 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3123 (UV)CopLINE(cCOPo));
3124 if (CopSTASHPV(cCOPo))
3125 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3127 if (CopLABEL(cCOPo))
3128 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3132 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3133 if (cLOOPo->op_redoop)
3134 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3136 PerlIO_printf(file, "DONE\"");
3137 S_xmldump_attr(aTHX_ level, file, "next=\"");
3138 if (cLOOPo->op_nextop)
3139 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3141 PerlIO_printf(file, "DONE\"");
3142 S_xmldump_attr(aTHX_ level, file, "last=\"");
3143 if (cLOOPo->op_lastop)
3144 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3146 PerlIO_printf(file, "DONE\"");
3154 S_xmldump_attr(aTHX_ level, file, "other=\"");
3155 if (cLOGOPo->op_other)
3156 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3158 PerlIO_printf(file, "DONE\"");
3166 if (o->op_private & OPpREFCOUNTED)
3167 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3173 if (PL_madskills && o->op_madprop) {
3174 char prevkey = '\0';
3175 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3176 const MADPROP* mp = o->op_madprop;
3180 PerlIO_printf(file, ">\n");
3182 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3185 char tmp = mp->mad_key;
3186 sv_setpvs(tmpsv,"\"");
3188 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3189 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3190 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3193 sv_catpv(tmpsv, "\"");
3194 switch (mp->mad_type) {
3196 sv_catpv(tmpsv, "NULL");
3197 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3200 sv_catpv(tmpsv, " val=\"");
3201 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3202 sv_catpv(tmpsv, "\"");
3203 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3206 sv_catpv(tmpsv, " val=\"");
3207 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3208 sv_catpv(tmpsv, "\"");
3209 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3212 if ((OP*)mp->mad_val) {
3213 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3214 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3215 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3219 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3225 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3227 SvREFCNT_dec(tmpsv);
3230 switch (o->op_type) {
3237 PerlIO_printf(file, ">\n");
3239 do_pmop_xmldump(level, file, cPMOPo);
3245 if (o->op_flags & OPf_KIDS) {
3249 PerlIO_printf(file, ">\n");
3251 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3252 do_op_xmldump(level, file, kid);
3256 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3258 PerlIO_printf(file, " />\n");
3262 Perl_op_xmldump(pTHX_ const OP *o)
3264 PERL_ARGS_ASSERT_OP_XMLDUMP;
3266 do_op_xmldump(0, PL_xmlfp, o);
3272 * c-indentation-style: bsd
3274 * indent-tabs-mode: t
3277 * ex: set ts=8 sts=4 sw=4 noet: