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_AMPER, ",AMPER"},
815 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
816 {OPpENTERSUB_INARGS, ",INARGS"}
819 const struct flag_to_name op_const_names[] = {
820 {OPpCONST_NOVER, ",NOVER"},
821 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
822 {OPpCONST_STRICT, ",STRICT"},
823 {OPpCONST_ENTERED, ",ENTERED"},
824 {OPpCONST_ARYBASE, ",ARYBASE"},
825 {OPpCONST_BARE, ",BARE"},
826 {OPpCONST_WARNING, ",WARNING"}
829 const struct flag_to_name op_sort_names[] = {
830 {OPpSORT_NUMERIC, ",NUMERIC"},
831 {OPpSORT_INTEGER, ",INTEGER"},
832 {OPpSORT_REVERSE, ",REVERSE"},
833 {OPpSORT_INPLACE, ",INPLACE"},
834 {OPpSORT_DESCEND, ",DESCEND"},
835 {OPpSORT_QSORT, ",QSORT"},
836 {OPpSORT_STABLE, ",STABLE"}
839 const struct flag_to_name op_open_names[] = {
840 {OPpOPEN_IN_RAW, ",IN_RAW"},
841 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
842 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
843 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
846 const struct flag_to_name op_exit_names[] = {
847 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
848 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
851 #define OP_PRIVATE_ONCE(op, flag, name) \
852 const struct flag_to_name CAT2(op, _names)[] = { \
856 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
857 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
858 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
859 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
860 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
861 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
862 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
863 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
864 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
865 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
866 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
867 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
869 struct op_private_by_op {
872 const struct flag_to_name *start;
875 const struct op_private_by_op op_private_names[] = {
876 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
877 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
878 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
879 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
880 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
881 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
882 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
883 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
884 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
885 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
886 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
887 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
888 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
889 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
890 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
891 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
892 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
893 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
894 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
895 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
896 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
900 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
901 const struct op_private_by_op *start = op_private_names;
902 const struct op_private_by_op *const end
903 = op_private_names + C_ARRAY_LENGTH(op_private_names);
905 /* This is a linear search, but no worse than the code that it replaced.
906 It's debugging code - size is more important than speed. */
908 if (optype == start->op_type) {
909 S_append_flags(aTHX_ tmpsv, op_private, start->start,
910 start->start + start->len);
913 } while (++start < end);
918 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
922 const OPCODE optype = o->op_type;
924 PERL_ARGS_ASSERT_DO_OP_DUMP;
927 Perl_dump_indent(aTHX_ level, file, "{\n");
929 seq = sequence_num(o);
931 PerlIO_printf(file, "%-4"UVuf, seq);
933 PerlIO_printf(file, " ");
935 "%*sTYPE = %s ===> ",
936 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
938 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
939 sequence_num(o->op_next));
941 PerlIO_printf(file, "DONE\n");
943 if (optype == OP_NULL) {
944 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
945 if (o->op_targ == OP_NEXTSTATE) {
947 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
949 if (CopSTASHPV(cCOPo))
950 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
953 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
958 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
961 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
963 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
964 SV * const tmpsv = newSVpvs("");
965 switch (o->op_flags & OPf_WANT) {
967 sv_catpv(tmpsv, ",VOID");
969 case OPf_WANT_SCALAR:
970 sv_catpv(tmpsv, ",SCALAR");
973 sv_catpv(tmpsv, ",LIST");
976 sv_catpv(tmpsv, ",UNKNOWN");
979 append_flags(tmpsv, o->op_flags, op_flags_names);
981 sv_catpv(tmpsv, ",LATEFREE");
983 sv_catpv(tmpsv, ",LATEFREED");
985 sv_catpv(tmpsv, ",ATTACHED");
986 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
990 SV * const tmpsv = newSVpvs("");
991 if (PL_opargs[optype] & OA_TARGLEX) {
992 if (o->op_private & OPpTARGET_MY)
993 sv_catpv(tmpsv, ",TARGET_MY");
995 else if (optype == OP_ENTERSUB ||
996 optype == OP_RV2SV ||
998 optype == OP_RV2AV ||
999 optype == OP_RV2HV ||
1000 optype == OP_RV2GV ||
1001 optype == OP_AELEM ||
1002 optype == OP_HELEM )
1004 if (optype == OP_ENTERSUB) {
1005 append_flags(tmpsv, o->op_private, op_entersub_names);
1008 switch (o->op_private & OPpDEREF) {
1010 sv_catpv(tmpsv, ",SV");
1013 sv_catpv(tmpsv, ",AV");
1016 sv_catpv(tmpsv, ",HV");
1019 if (o->op_private & OPpMAYBE_LVSUB)
1020 sv_catpv(tmpsv, ",MAYBE_LVSUB");
1023 if (optype == OP_AELEM || optype == OP_HELEM) {
1024 if (o->op_private & OPpLVAL_DEFER)
1025 sv_catpv(tmpsv, ",LVAL_DEFER");
1028 if (o->op_private & HINT_STRICT_REFS)
1029 sv_catpv(tmpsv, ",STRICT_REFS");
1030 if (o->op_private & OPpOUR_INTRO)
1031 sv_catpv(tmpsv, ",OUR_INTRO");
1034 else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
1036 else if (PL_check[optype] != Perl_ck_ftst) {
1037 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1038 sv_catpv(tmpsv, ",FT_ACCESS");
1039 if (o->op_private & OPpFT_STACKED)
1040 sv_catpv(tmpsv, ",FT_STACKED");
1042 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1043 sv_catpv(tmpsv, ",INTRO");
1045 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1046 SvREFCNT_dec(tmpsv);
1050 if (PL_madskills && o->op_madprop) {
1051 SV * const tmpsv = newSVpvs("");
1052 MADPROP* mp = o->op_madprop;
1053 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1056 const char tmp = mp->mad_key;
1057 sv_setpvs(tmpsv,"'");
1059 sv_catpvn(tmpsv, &tmp, 1);
1060 sv_catpv(tmpsv, "'=");
1061 switch (mp->mad_type) {
1063 sv_catpv(tmpsv, "NULL");
1064 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1067 sv_catpv(tmpsv, "<");
1068 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1069 sv_catpv(tmpsv, ">");
1070 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1073 if ((OP*)mp->mad_val) {
1074 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1075 do_op_dump(level, file, (OP*)mp->mad_val);
1079 sv_catpv(tmpsv, "(UNK)");
1080 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1086 Perl_dump_indent(aTHX_ level, file, "}\n");
1088 SvREFCNT_dec(tmpsv);
1097 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1099 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1100 if (cSVOPo->op_sv) {
1101 SV * const tmpsv = newSV(0);
1105 /* FIXME - is this making unwarranted assumptions about the
1106 UTF-8 cleanliness of the dump file handle? */
1109 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1110 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1111 SvPV_nolen_const(tmpsv));
1115 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1121 case OP_METHOD_NAMED:
1122 #ifndef USE_ITHREADS
1123 /* with ITHREADS, consts are stored in the pad, and the right pad
1124 * may not be active here, so skip */
1125 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1131 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1132 (UV)CopLINE(cCOPo));
1133 if (CopSTASHPV(cCOPo))
1134 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1136 if (CopLABEL(cCOPo))
1137 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1141 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1142 if (cLOOPo->op_redoop)
1143 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1145 PerlIO_printf(file, "DONE\n");
1146 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1147 if (cLOOPo->op_nextop)
1148 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1150 PerlIO_printf(file, "DONE\n");
1151 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1152 if (cLOOPo->op_lastop)
1153 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1155 PerlIO_printf(file, "DONE\n");
1163 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1164 if (cLOGOPo->op_other)
1165 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1167 PerlIO_printf(file, "DONE\n");
1173 do_pmop_dump(level, file, cPMOPo);
1181 if (o->op_private & OPpREFCOUNTED)
1182 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1187 if (o->op_flags & OPf_KIDS) {
1189 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1190 do_op_dump(level, file, kid);
1192 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1196 Perl_op_dump(pTHX_ const OP *o)
1198 PERL_ARGS_ASSERT_OP_DUMP;
1199 do_op_dump(0, Perl_debug_log, o);
1203 Perl_gv_dump(pTHX_ GV *gv)
1207 PERL_ARGS_ASSERT_GV_DUMP;
1210 PerlIO_printf(Perl_debug_log, "{}\n");
1213 sv = sv_newmortal();
1214 PerlIO_printf(Perl_debug_log, "{\n");
1215 gv_fullname3(sv, gv, NULL);
1216 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1217 if (gv != GvEGV(gv)) {
1218 gv_efullname3(sv, GvEGV(gv), NULL);
1219 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1221 PerlIO_putc(Perl_debug_log, '\n');
1222 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1226 /* map magic types to the symbolic names
1227 * (with the PERL_MAGIC_ prefixed stripped)
1230 static const struct { const char type; const char *name; } magic_names[] = {
1231 #include "mg_names.c"
1232 /* this null string terminates the list */
1237 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1239 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1241 for (; mg; mg = mg->mg_moremagic) {
1242 Perl_dump_indent(aTHX_ level, file,
1243 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1244 if (mg->mg_virtual) {
1245 const MGVTBL * const v = mg->mg_virtual;
1246 if (v >= PL_magic_vtables
1247 && v < PL_magic_vtables + magic_vtable_max) {
1248 const U32 i = v - PL_magic_vtables;
1249 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1252 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1255 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1258 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1262 const char *name = NULL;
1263 for (n = 0; magic_names[n].name; n++) {
1264 if (mg->mg_type == magic_names[n].type) {
1265 name = magic_names[n].name;
1270 Perl_dump_indent(aTHX_ level, file,
1271 " MG_TYPE = PERL_MAGIC_%s\n", name);
1273 Perl_dump_indent(aTHX_ level, file,
1274 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1278 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1279 if (mg->mg_type == PERL_MAGIC_envelem &&
1280 mg->mg_flags & MGf_TAINTEDDIR)
1281 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1282 if (mg->mg_type == PERL_MAGIC_regex_global &&
1283 mg->mg_flags & MGf_MINMATCH)
1284 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1285 if (mg->mg_flags & MGf_REFCOUNTED)
1286 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1287 if (mg->mg_flags & MGf_GSKIP)
1288 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1289 if (mg->mg_flags & MGf_COPY)
1290 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1291 if (mg->mg_flags & MGf_DUP)
1292 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1293 if (mg->mg_flags & MGf_LOCAL)
1294 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1297 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1298 PTR2UV(mg->mg_obj));
1299 if (mg->mg_type == PERL_MAGIC_qr) {
1300 REGEXP* const re = (REGEXP *)mg->mg_obj;
1301 SV * const dsv = sv_newmortal();
1302 const char * const s
1303 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1305 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1306 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1308 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1309 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1312 if (mg->mg_flags & MGf_REFCOUNTED)
1313 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1316 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1318 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1319 if (mg->mg_len >= 0) {
1320 if (mg->mg_type != PERL_MAGIC_utf8) {
1321 SV * const sv = newSVpvs("");
1322 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1326 else if (mg->mg_len == HEf_SVKEY) {
1327 PerlIO_puts(file, " => HEf_SVKEY\n");
1328 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1329 maxnest, dumpops, pvlim); /* MG is already +1 */
1332 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1337 " does not know how to handle this MG_LEN"
1339 PerlIO_putc(file, '\n');
1341 if (mg->mg_type == PERL_MAGIC_utf8) {
1342 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1345 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1346 Perl_dump_indent(aTHX_ level, file,
1347 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1350 (UV)cache[i * 2 + 1]);
1357 Perl_magic_dump(pTHX_ const MAGIC *mg)
1359 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1363 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1367 PERL_ARGS_ASSERT_DO_HV_DUMP;
1369 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1370 if (sv && (hvname = HvNAME_get(sv)))
1372 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1373 name which quite legally could contain insane things like tabs, newlines, nulls or
1374 other scary crap - this should produce sane results - except maybe for unicode package
1375 names - but we will wait for someone to file a bug on that - demerphq */
1376 SV * const tmpsv = newSVpvs("");
1377 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1380 PerlIO_putc(file, '\n');
1384 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1386 PERL_ARGS_ASSERT_DO_GV_DUMP;
1388 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1389 if (sv && GvNAME(sv))
1390 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1392 PerlIO_putc(file, '\n');
1396 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1398 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1400 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1401 if (sv && GvNAME(sv)) {
1403 PerlIO_printf(file, "\t\"");
1404 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1405 PerlIO_printf(file, "%s\" :: \"", hvname);
1406 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1409 PerlIO_putc(file, '\n');
1412 const struct flag_to_name first_sv_flags_names[] = {
1413 {SVs_TEMP, "TEMP,"},
1414 {SVs_OBJECT, "OBJECT,"},
1423 const struct flag_to_name second_sv_flags_names[] = {
1425 {SVf_FAKE, "FAKE,"},
1426 {SVf_READONLY, "READONLY,"},
1427 {SVf_BREAK, "BREAK,"},
1428 {SVf_AMAGIC, "OVERLOAD,"},
1434 const struct flag_to_name cv_flags_names[] = {
1435 {CVf_ANON, "ANON,"},
1436 {CVf_UNIQUE, "UNIQUE,"},
1437 {CVf_CLONE, "CLONE,"},
1438 {CVf_CLONED, "CLONED,"},
1439 {CVf_CONST, "CONST,"},
1440 {CVf_NODEBUG, "NODEBUG,"},
1441 {CVf_LVALUE, "LVALUE,"},
1442 {CVf_METHOD, "METHOD,"},
1443 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1444 {CVf_CVGV_RC, "CVGV_RC,"},
1445 {CVf_DYNFILE, "DYNFILE,"},
1446 {CVf_ISXSUB, "ISXSUB,"}
1449 const struct flag_to_name hv_flags_names[] = {
1450 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1451 {SVphv_LAZYDEL, "LAZYDEL,"},
1452 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1453 {SVphv_REHASH, "REHASH,"},
1454 {SVphv_CLONEABLE, "CLONEABLE,"}
1457 const struct flag_to_name gp_flags_names[] = {
1458 {GVf_INTRO, "INTRO,"},
1459 {GVf_MULTI, "MULTI,"},
1460 {GVf_ASSUMECV, "ASSUMECV,"},
1461 {GVf_IN_PAD, "IN_PAD,"}
1464 const struct flag_to_name gp_flags_imported_names[] = {
1465 {GVf_IMPORTED_SV, " SV"},
1466 {GVf_IMPORTED_AV, " AV"},
1467 {GVf_IMPORTED_HV, " HV"},
1468 {GVf_IMPORTED_CV, " CV"},
1471 const struct flag_to_name regexp_flags_names[] = {
1472 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1473 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1474 {RXf_PMf_FOLD, "PMf_FOLD,"},
1475 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
1476 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
1477 {RXf_ANCH_BOL, "ANCH_BOL,"},
1478 {RXf_ANCH_MBOL, "ANCH_MBOL,"},
1479 {RXf_ANCH_SBOL, "ANCH_SBOL,"},
1480 {RXf_ANCH_GPOS, "ANCH_GPOS,"},
1481 {RXf_GPOS_SEEN, "GPOS_SEEN,"},
1482 {RXf_GPOS_FLOAT, "GPOS_FLOAT,"},
1483 {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1484 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
1485 {RXf_CANY_SEEN, "CANY_SEEN,"},
1486 {RXf_NOSCAN, "NOSCAN,"},
1487 {RXf_CHECK_ALL, "CHECK_ALL,"},
1488 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1489 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1490 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1491 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
1492 {RXf_SPLIT, "SPLIT,"},
1493 {RXf_COPY_DONE, "COPY_DONE,"},
1494 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1495 {RXf_TAINTED, "TAINTED,"},
1496 {RXf_START_ONLY, "START_ONLY,"},
1497 {RXf_SKIPWHITE, "SKIPWHITE,"},
1498 {RXf_WHITE, "WHITE,"},
1499 {RXf_NULL, "NULL,"},
1503 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1511 PERL_ARGS_ASSERT_DO_SV_DUMP;
1514 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1518 flags = SvFLAGS(sv);
1521 /* process general SV flags */
1523 d = Perl_newSVpvf(aTHX_
1524 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1525 PTR2UV(SvANY(sv)), PTR2UV(sv),
1526 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1527 (int)(PL_dumpindent*level), "");
1529 if (!((flags & SVpad_NAME) == SVpad_NAME
1530 && (type == SVt_PVMG || type == SVt_PVNV))) {
1531 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1533 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1534 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1535 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1537 append_flags(d, flags, first_sv_flags_names);
1538 if (flags & SVf_ROK) {
1539 sv_catpv(d, "ROK,");
1540 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1542 append_flags(d, flags, second_sv_flags_names);
1543 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1544 if (SvPCS_IMPORTED(sv))
1545 sv_catpv(d, "PCS_IMPORTED,");
1547 sv_catpv(d, "SCREAM,");
1550 /* process type-specific SV flags */
1555 append_flags(d, CvFLAGS(sv), cv_flags_names);
1558 append_flags(d, flags, hv_flags_names);
1562 if (isGV_with_GP(sv)) {
1563 append_flags(d, GvFLAGS(sv), gp_flags_names);
1565 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1566 sv_catpv(d, "IMPORT");
1567 if (GvIMPORTED(sv) == GVf_IMPORTED)
1568 sv_catpv(d, "ALL,");
1571 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1578 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1579 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1582 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1583 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1584 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1585 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1588 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1593 /* SVphv_SHAREKEYS is also 0x20000000 */
1594 if ((type != SVt_PVHV) && SvUTF8(sv))
1595 sv_catpv(d, "UTF8");
1597 if (*(SvEND(d) - 1) == ',') {
1598 SvCUR_set(d, SvCUR(d) - 1);
1599 SvPVX(d)[SvCUR(d)] = '\0';
1604 /* dump initial SV details */
1606 #ifdef DEBUG_LEAKING_SCALARS
1607 Perl_dump_indent(aTHX_ level, file,
1608 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1609 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1611 sv->sv_debug_inpad ? "for" : "by",
1612 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1613 PTR2UV(sv->sv_debug_parent),
1617 Perl_dump_indent(aTHX_ level, file, "SV = ");
1621 if (type < SVt_LAST) {
1622 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1624 if (type == SVt_NULL) {
1629 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1634 /* Dump general SV fields */
1636 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1637 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1638 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1639 || (type == SVt_IV && !SvROK(sv))) {
1641 #ifdef PERL_OLD_COPY_ON_WRITE
1645 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1647 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1648 #ifdef PERL_OLD_COPY_ON_WRITE
1649 if (SvIsCOW_shared_hash(sv))
1650 PerlIO_printf(file, " (HASH)");
1651 else if (SvIsCOW_normal(sv))
1652 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1654 PerlIO_putc(file, '\n');
1657 if ((type == SVt_PVNV || type == SVt_PVMG)
1658 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1659 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1660 (UV) COP_SEQ_RANGE_LOW(sv));
1661 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1662 (UV) COP_SEQ_RANGE_HIGH(sv));
1663 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1664 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1665 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1666 || type == SVt_NV) {
1667 STORE_NUMERIC_LOCAL_SET_STANDARD();
1668 /* %Vg doesn't work? --jhi */
1669 #ifdef USE_LONG_DOUBLE
1670 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1672 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1674 RESTORE_NUMERIC_LOCAL();
1678 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1680 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1683 if (type < SVt_PV) {
1688 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1689 if (SvPVX_const(sv)) {
1692 SvOOK_offset(sv, delta);
1693 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1698 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1700 PerlIO_printf(file, "( %s . ) ",
1701 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1704 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1705 if (SvUTF8(sv)) /* the 6? \x{....} */
1706 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1707 PerlIO_printf(file, "\n");
1708 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1709 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1712 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1715 if (type >= SVt_PVMG) {
1716 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1717 HV * const ost = SvOURSTASH(sv);
1719 do_hv_dump(level, file, " OURSTASH", ost);
1722 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1725 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1727 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1728 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1729 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1730 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1734 /* Dump type-specific SV fields */
1738 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1739 if (AvARRAY(sv) != AvALLOC(sv)) {
1740 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1741 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1744 PerlIO_putc(file, '\n');
1745 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1746 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1747 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1749 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1750 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1751 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1752 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1753 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1755 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1756 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1758 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1760 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1765 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1766 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1767 /* Show distribution of HEs in the ARRAY */
1769 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1772 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1773 NV theoret, sum = 0;
1775 PerlIO_printf(file, " (");
1776 Zero(freq, FREQ_MAX + 1, int);
1777 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1780 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1782 if (count > FREQ_MAX)
1788 for (i = 0; i <= max; i++) {
1790 PerlIO_printf(file, "%d%s:%d", i,
1791 (i == FREQ_MAX) ? "+" : "",
1794 PerlIO_printf(file, ", ");
1797 PerlIO_putc(file, ')');
1798 /* The "quality" of a hash is defined as the total number of
1799 comparisons needed to access every element once, relative
1800 to the expected number needed for a random hash.
1802 The total number of comparisons is equal to the sum of
1803 the squares of the number of entries in each bucket.
1804 For a random hash of n keys into k buckets, the expected
1809 for (i = max; i > 0; i--) { /* Precision: count down. */
1810 sum += freq[i] * i * i;
1812 while ((keys = keys >> 1))
1814 theoret = HvUSEDKEYS(sv);
1815 theoret += theoret * (theoret-1)/pow2;
1816 PerlIO_putc(file, '\n');
1817 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1819 PerlIO_putc(file, '\n');
1820 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1821 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1822 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1823 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1824 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1826 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1827 if (mg && mg->mg_obj) {
1828 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1832 const char * const hvname = HvNAME_get(sv);
1834 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1838 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1839 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1840 if (HvAUX(sv)->xhv_name_count)
1841 Perl_dump_indent(aTHX_
1842 level, file, " NAMECOUNT = %"IVdf"\n",
1843 (IV)HvAUX(sv)->xhv_name_count
1845 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1846 const I32 count = HvAUX(sv)->xhv_name_count;
1848 SV * const names = newSVpvs_flags("", SVs_TEMP);
1849 /* The starting point is the first element if count is
1850 positive and the second element if count is negative. */
1851 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1852 + (count < 0 ? 1 : 0);
1853 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1854 + (count < 0 ? -count : count);
1855 while (hekp < endp) {
1857 sv_catpvs(names, ", \"");
1858 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1859 sv_catpvs(names, "\"");
1861 /* This should never happen. */
1862 sv_catpvs(names, ", (null)");
1866 Perl_dump_indent(aTHX_
1867 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1871 Perl_dump_indent(aTHX_
1872 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1876 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1878 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1882 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1883 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1884 (int)meta->mro_which->length,
1885 meta->mro_which->name,
1886 PTR2UV(meta->mro_which));
1887 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1888 (UV)meta->cache_gen);
1889 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1891 if (meta->mro_linear_all) {
1892 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1893 PTR2UV(meta->mro_linear_all));
1894 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1897 if (meta->mro_linear_current) {
1898 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1899 PTR2UV(meta->mro_linear_current));
1900 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1903 if (meta->mro_nextmethod) {
1904 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1905 PTR2UV(meta->mro_nextmethod));
1906 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1910 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1912 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1917 if (nest < maxnest) {
1918 HV * const hv = MUTABLE_HV(sv);
1923 int count = maxnest - nest;
1924 for (i=0; i <= HvMAX(hv); i++) {
1925 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1932 if (count-- <= 0) goto DONEHV;
1935 keysv = hv_iterkeysv(he);
1936 keypv = SvPV_const(keysv, len);
1939 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1941 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1942 if (HvEITER_get(hv) == he)
1943 PerlIO_printf(file, "[CURRENT] ");
1945 PerlIO_printf(file, "[REHASH] ");
1946 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1947 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1958 const char *const proto = SvPV_const(sv, len);
1959 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1964 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1965 if (!CvISXSUB(sv)) {
1967 Perl_dump_indent(aTHX_ level, file,
1968 " START = 0x%"UVxf" ===> %"IVdf"\n",
1969 PTR2UV(CvSTART(sv)),
1970 (IV)sequence_num(CvSTART(sv)));
1972 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1973 PTR2UV(CvROOT(sv)));
1974 if (CvROOT(sv) && dumpops) {
1975 do_op_dump(level+1, file, CvROOT(sv));
1978 SV * const constant = cv_const_sv((const CV *)sv);
1980 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1983 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1985 PTR2UV(CvXSUBANY(sv).any_ptr));
1986 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1989 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1990 (IV)CvXSUBANY(sv).any_i32);
1993 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1994 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1995 if (type == SVt_PVCV)
1996 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1997 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1998 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1999 if (type == SVt_PVFM)
2000 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
2001 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2002 if (nest < maxnest) {
2003 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2006 const CV * const outside = CvOUTSIDE(sv);
2007 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2010 : CvANON(outside) ? "ANON"
2011 : (outside == PL_main_cv) ? "MAIN"
2012 : CvUNIQUE(outside) ? "UNIQUE"
2013 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2015 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2016 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2021 if (type == SVt_PVLV) {
2022 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2023 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2024 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2025 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2026 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2027 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2030 if (!isGV_with_GP(sv))
2032 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2033 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2034 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2035 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2038 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2040 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2041 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2042 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2043 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2044 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2045 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2046 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2047 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2048 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2049 do_gv_dump (level, file, " EGV", GvEGV(sv));
2052 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2053 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2054 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2055 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2056 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2057 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2058 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2060 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2061 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2062 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2064 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2065 PTR2UV(IoTOP_GV(sv)));
2066 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2067 maxnest, dumpops, pvlim);
2069 /* Source filters hide things that are not GVs in these three, so let's
2070 be careful out there. */
2072 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2073 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2074 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2076 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2077 PTR2UV(IoFMT_GV(sv)));
2078 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2079 maxnest, dumpops, pvlim);
2081 if (IoBOTTOM_NAME(sv))
2082 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2083 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2084 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2086 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2087 PTR2UV(IoBOTTOM_GV(sv)));
2088 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2089 maxnest, dumpops, pvlim);
2091 if (isPRINT(IoTYPE(sv)))
2092 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2094 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2095 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2099 struct regexp * const r = (struct regexp *)SvANY(sv);
2100 flags = RX_EXTFLAGS((REGEXP*)sv);
2102 append_flags(d, flags, regexp_flags_names);
2103 if (*(SvEND(d) - 1) == ',') {
2104 SvCUR_set(d, SvCUR(d) - 1);
2105 SvPVX(d)[SvCUR(d)] = '\0';
2107 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2108 (UV)flags, SvPVX_const(d));
2109 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2111 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2113 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2114 (UV)(r->lastparen));
2115 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2116 (UV)(r->lastcloseparen));
2117 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2119 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2120 (IV)(r->minlenret));
2121 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2123 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2124 (UV)(r->pre_prefix));
2125 Perl_dump_indent(aTHX_ level, file, " SEEN_EVALS = %"UVuf"\n",
2126 (UV)(r->seen_evals));
2127 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2130 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2132 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2134 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2135 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2137 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2138 PTR2UV(r->mother_re));
2139 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2140 PTR2UV(r->paren_names));
2141 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2142 PTR2UV(r->substrs));
2143 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2144 PTR2UV(r->pprivate));
2145 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2147 #ifdef PERL_OLD_COPY_ON_WRITE
2148 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2149 PTR2UV(r->saved_copy));
2158 Perl_sv_dump(pTHX_ SV *sv)
2162 PERL_ARGS_ASSERT_SV_DUMP;
2165 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2167 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2171 Perl_runops_debug(pTHX)
2175 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2179 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2182 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2183 PerlIO_printf(Perl_debug_log,
2184 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2185 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2186 PTR2UV(*PL_watchaddr));
2187 if (DEBUG_s_TEST_) {
2188 if (DEBUG_v_TEST_) {
2189 PerlIO_printf(Perl_debug_log, "\n");
2197 if (DEBUG_t_TEST_) debop(PL_op);
2198 if (DEBUG_P_TEST_) debprof(PL_op);
2200 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2201 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2208 Perl_debop(pTHX_ const OP *o)
2212 PERL_ARGS_ASSERT_DEBOP;
2214 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2217 Perl_deb(aTHX_ "%s", OP_NAME(o));
2218 switch (o->op_type) {
2221 /* With ITHREADS, consts are stored in the pad, and the right pad
2222 * may not be active here, so check.
2223 * Looks like only during compiling the pads are illegal.
2226 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2228 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2233 SV * const sv = newSV(0);
2235 /* FIXME - is this making unwarranted assumptions about the
2236 UTF-8 cleanliness of the dump file handle? */
2239 gv_fullname3(sv, cGVOPo_gv, NULL);
2240 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2244 PerlIO_printf(Perl_debug_log, "(NULL)");
2250 /* print the lexical's name */
2251 CV * const cv = deb_curcv(cxstack_ix);
2254 AV * const padlist = CvPADLIST(cv);
2255 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2256 sv = *av_fetch(comppad, o->op_targ, FALSE);
2260 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2262 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2268 PerlIO_printf(Perl_debug_log, "\n");
2273 S_deb_curcv(pTHX_ const I32 ix)
2276 const PERL_CONTEXT * const cx = &cxstack[ix];
2277 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2278 return cx->blk_sub.cv;
2279 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2281 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2286 return deb_curcv(ix - 1);
2290 Perl_watch(pTHX_ char **addr)
2294 PERL_ARGS_ASSERT_WATCH;
2296 PL_watchaddr = addr;
2298 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2299 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2303 S_debprof(pTHX_ const OP *o)
2307 PERL_ARGS_ASSERT_DEBPROF;
2309 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2311 if (!PL_profiledata)
2312 Newxz(PL_profiledata, MAXO, U32);
2313 ++PL_profiledata[o->op_type];
2317 Perl_debprofdump(pTHX)
2321 if (!PL_profiledata)
2323 for (i = 0; i < MAXO; i++) {
2324 if (PL_profiledata[i])
2325 PerlIO_printf(Perl_debug_log,
2326 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2333 * XML variants of most of the above routines
2337 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2341 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2343 PerlIO_printf(file, "\n ");
2344 va_start(args, pat);
2345 xmldump_vindent(level, file, pat, &args);
2351 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2354 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2355 va_start(args, pat);
2356 xmldump_vindent(level, file, pat, &args);
2361 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2363 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2365 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2366 PerlIO_vprintf(file, pat, *args);
2370 Perl_xmldump_all(pTHX)
2372 xmldump_all_perl(FALSE);
2376 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2378 PerlIO_setlinebuf(PL_xmlfp);
2380 op_xmldump(PL_main_root);
2381 /* someday we might call this, when it outputs XML: */
2382 /* xmldump_packsubs_perl(PL_defstash, justperl); */
2383 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2384 PerlIO_close(PL_xmlfp);
2389 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2391 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2392 xmldump_packsubs_perl(stash, FALSE);
2396 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2401 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2403 if (!HvARRAY(stash))
2405 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2406 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2407 GV *gv = MUTABLE_GV(HeVAL(entry));
2409 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2412 xmldump_sub_perl(gv, justperl);
2415 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2416 && (hv = GvHV(gv)) && hv != PL_defstash)
2417 xmldump_packsubs_perl(hv, justperl); /* nested package */
2423 Perl_xmldump_sub(pTHX_ const GV *gv)
2425 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2426 xmldump_sub_perl(gv, FALSE);
2430 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2434 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2436 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2439 sv = sv_newmortal();
2440 gv_fullname3(sv, gv, NULL);
2441 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2442 if (CvXSUB(GvCV(gv)))
2443 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2444 PTR2UV(CvXSUB(GvCV(gv))),
2445 (int)CvXSUBANY(GvCV(gv)).any_i32);
2446 else if (CvROOT(GvCV(gv)))
2447 op_xmldump(CvROOT(GvCV(gv)));
2449 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2453 Perl_xmldump_form(pTHX_ const GV *gv)
2455 SV * const sv = sv_newmortal();
2457 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2459 gv_fullname3(sv, gv, NULL);
2460 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2461 if (CvROOT(GvFORM(gv)))
2462 op_xmldump(CvROOT(GvFORM(gv)));
2464 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2468 Perl_xmldump_eval(pTHX)
2470 op_xmldump(PL_eval_root);
2474 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2476 PERL_ARGS_ASSERT_SV_CATXMLSV;
2477 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2481 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2483 PERL_ARGS_ASSERT_SV_CATXMLPV;
2484 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2488 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2491 const char * const e = pv + len;
2492 const char * const start = pv;
2496 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2499 dsvcur = SvCUR(dsv); /* in case we have to restart */
2504 c = utf8_to_uvchr((U8*)pv, &cl);
2506 SvCUR(dsv) = dsvcur;
2571 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2574 sv_catpvs(dsv, "<");
2577 sv_catpvs(dsv, ">");
2580 sv_catpvs(dsv, "&");
2583 sv_catpvs(dsv, """);
2587 if (c < 32 || c > 127) {
2588 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2591 const char string = (char) c;
2592 sv_catpvn(dsv, &string, 1);
2596 if ((c >= 0xD800 && c <= 0xDB7F) ||
2597 (c >= 0xDC00 && c <= 0xDFFF) ||
2598 (c >= 0xFFF0 && c <= 0xFFFF) ||
2600 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2602 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2615 Perl_sv_xmlpeek(pTHX_ SV *sv)
2617 SV * const t = sv_newmortal();
2621 PERL_ARGS_ASSERT_SV_XMLPEEK;
2627 sv_catpv(t, "VOID=\"\"");
2630 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2631 sv_catpv(t, "WILD=\"\"");
2634 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2635 if (sv == &PL_sv_undef) {
2636 sv_catpv(t, "SV_UNDEF=\"1\"");
2637 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2638 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2642 else if (sv == &PL_sv_no) {
2643 sv_catpv(t, "SV_NO=\"1\"");
2644 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2645 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2646 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2647 SVp_POK|SVp_NOK)) &&
2652 else if (sv == &PL_sv_yes) {
2653 sv_catpv(t, "SV_YES=\"1\"");
2654 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2655 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2656 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2657 SVp_POK|SVp_NOK)) &&
2659 SvPVX(sv) && *SvPVX(sv) == '1' &&
2664 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2665 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2666 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2670 sv_catpv(t, " XXX=\"\" ");
2672 else if (SvREFCNT(sv) == 0) {
2673 sv_catpv(t, " refcnt=\"0\"");
2676 else if (DEBUG_R_TEST_) {
2679 /* is this SV on the tmps stack? */
2680 for (ix=PL_tmps_ix; ix>=0; ix--) {
2681 if (PL_tmps_stack[ix] == sv) {
2686 if (SvREFCNT(sv) > 1)
2687 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2690 sv_catpv(t, " DRT=\"<T>\"");
2694 sv_catpv(t, " ROK=\"\"");
2696 switch (SvTYPE(sv)) {
2698 sv_catpv(t, " FREED=\"1\"");
2702 sv_catpv(t, " UNDEF=\"1\"");
2705 sv_catpv(t, " IV=\"");
2708 sv_catpv(t, " NV=\"");
2711 sv_catpv(t, " PV=\"");
2714 sv_catpv(t, " PVIV=\"");
2717 sv_catpv(t, " PVNV=\"");
2720 sv_catpv(t, " PVMG=\"");
2723 sv_catpv(t, " PVLV=\"");
2726 sv_catpv(t, " AV=\"");
2729 sv_catpv(t, " HV=\"");
2733 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2735 sv_catpv(t, " CV=\"()\"");
2738 sv_catpv(t, " GV=\"");
2741 sv_catpv(t, " BIND=\"");
2744 sv_catpv(t, " REGEXP=\"");
2747 sv_catpv(t, " FM=\"");
2750 sv_catpv(t, " IO=\"");
2759 else if (SvNOKp(sv)) {
2760 STORE_NUMERIC_LOCAL_SET_STANDARD();
2761 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2762 RESTORE_NUMERIC_LOCAL();
2764 else if (SvIOKp(sv)) {
2766 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2768 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2777 return SvPV(t, n_a);
2781 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2783 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2786 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2789 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2792 REGEXP *const r = PM_GETRE(pm);
2793 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2794 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2795 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2797 SvREFCNT_dec(tmpsv);
2798 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2799 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2802 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2803 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2804 SV * const tmpsv = pm_description(pm);
2805 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2806 SvREFCNT_dec(tmpsv);
2810 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2811 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2812 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2813 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2814 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2815 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2818 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2822 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2824 do_pmop_xmldump(0, PL_xmlfp, pm);
2828 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2833 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2838 seq = sequence_num(o);
2839 Perl_xmldump_indent(aTHX_ level, file,
2840 "<op_%s seq=\"%"UVuf" -> ",
2845 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2846 sequence_num(o->op_next));
2848 PerlIO_printf(file, "DONE\"");
2851 if (o->op_type == OP_NULL)
2853 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2854 if (o->op_targ == OP_NEXTSTATE)
2857 PerlIO_printf(file, " line=\"%"UVuf"\"",
2858 (UV)CopLINE(cCOPo));
2859 if (CopSTASHPV(cCOPo))
2860 PerlIO_printf(file, " package=\"%s\"",
2862 if (CopLABEL(cCOPo))
2863 PerlIO_printf(file, " label=\"%s\"",
2868 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2871 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2874 SV * const tmpsv = newSVpvs("");
2875 switch (o->op_flags & OPf_WANT) {
2877 sv_catpv(tmpsv, ",VOID");
2879 case OPf_WANT_SCALAR:
2880 sv_catpv(tmpsv, ",SCALAR");
2883 sv_catpv(tmpsv, ",LIST");
2886 sv_catpv(tmpsv, ",UNKNOWN");
2889 if (o->op_flags & OPf_KIDS)
2890 sv_catpv(tmpsv, ",KIDS");
2891 if (o->op_flags & OPf_PARENS)
2892 sv_catpv(tmpsv, ",PARENS");
2893 if (o->op_flags & OPf_STACKED)
2894 sv_catpv(tmpsv, ",STACKED");
2895 if (o->op_flags & OPf_REF)
2896 sv_catpv(tmpsv, ",REF");
2897 if (o->op_flags & OPf_MOD)
2898 sv_catpv(tmpsv, ",MOD");
2899 if (o->op_flags & OPf_SPECIAL)
2900 sv_catpv(tmpsv, ",SPECIAL");
2901 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2902 SvREFCNT_dec(tmpsv);
2904 if (o->op_private) {
2905 SV * const tmpsv = newSVpvs("");
2906 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2907 if (o->op_private & OPpTARGET_MY)
2908 sv_catpv(tmpsv, ",TARGET_MY");
2910 else if (o->op_type == OP_LEAVESUB ||
2911 o->op_type == OP_LEAVE ||
2912 o->op_type == OP_LEAVESUBLV ||
2913 o->op_type == OP_LEAVEWRITE) {
2914 if (o->op_private & OPpREFCOUNTED)
2915 sv_catpv(tmpsv, ",REFCOUNTED");
2917 else if (o->op_type == OP_AASSIGN) {
2918 if (o->op_private & OPpASSIGN_COMMON)
2919 sv_catpv(tmpsv, ",COMMON");
2921 else if (o->op_type == OP_SASSIGN) {
2922 if (o->op_private & OPpASSIGN_BACKWARDS)
2923 sv_catpv(tmpsv, ",BACKWARDS");
2925 else if (o->op_type == OP_TRANS) {
2926 if (o->op_private & OPpTRANS_SQUASH)
2927 sv_catpv(tmpsv, ",SQUASH");
2928 if (o->op_private & OPpTRANS_DELETE)
2929 sv_catpv(tmpsv, ",DELETE");
2930 if (o->op_private & OPpTRANS_COMPLEMENT)
2931 sv_catpv(tmpsv, ",COMPLEMENT");
2932 if (o->op_private & OPpTRANS_IDENTICAL)
2933 sv_catpv(tmpsv, ",IDENTICAL");
2934 if (o->op_private & OPpTRANS_GROWS)
2935 sv_catpv(tmpsv, ",GROWS");
2937 else if (o->op_type == OP_REPEAT) {
2938 if (o->op_private & OPpREPEAT_DOLIST)
2939 sv_catpv(tmpsv, ",DOLIST");
2941 else if (o->op_type == OP_ENTERSUB ||
2942 o->op_type == OP_RV2SV ||
2943 o->op_type == OP_GVSV ||
2944 o->op_type == OP_RV2AV ||
2945 o->op_type == OP_RV2HV ||
2946 o->op_type == OP_RV2GV ||
2947 o->op_type == OP_AELEM ||
2948 o->op_type == OP_HELEM )
2950 if (o->op_type == OP_ENTERSUB) {
2951 if (o->op_private & OPpENTERSUB_AMPER)
2952 sv_catpv(tmpsv, ",AMPER");
2953 if (o->op_private & OPpENTERSUB_DB)
2954 sv_catpv(tmpsv, ",DB");
2955 if (o->op_private & OPpENTERSUB_HASTARG)
2956 sv_catpv(tmpsv, ",HASTARG");
2957 if (o->op_private & OPpENTERSUB_NOPAREN)
2958 sv_catpv(tmpsv, ",NOPAREN");
2959 if (o->op_private & OPpENTERSUB_INARGS)
2960 sv_catpv(tmpsv, ",INARGS");
2963 switch (o->op_private & OPpDEREF) {
2965 sv_catpv(tmpsv, ",SV");
2968 sv_catpv(tmpsv, ",AV");
2971 sv_catpv(tmpsv, ",HV");
2974 if (o->op_private & OPpMAYBE_LVSUB)
2975 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2977 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2978 if (o->op_private & OPpLVAL_DEFER)
2979 sv_catpv(tmpsv, ",LVAL_DEFER");
2982 if (o->op_private & HINT_STRICT_REFS)
2983 sv_catpv(tmpsv, ",STRICT_REFS");
2984 if (o->op_private & OPpOUR_INTRO)
2985 sv_catpv(tmpsv, ",OUR_INTRO");
2988 else if (o->op_type == OP_CONST) {
2989 if (o->op_private & OPpCONST_BARE)
2990 sv_catpv(tmpsv, ",BARE");
2991 if (o->op_private & OPpCONST_STRICT)
2992 sv_catpv(tmpsv, ",STRICT");
2993 if (o->op_private & OPpCONST_ARYBASE)
2994 sv_catpv(tmpsv, ",ARYBASE");
2995 if (o->op_private & OPpCONST_WARNING)
2996 sv_catpv(tmpsv, ",WARNING");
2997 if (o->op_private & OPpCONST_ENTERED)
2998 sv_catpv(tmpsv, ",ENTERED");
3000 else if (o->op_type == OP_FLIP) {
3001 if (o->op_private & OPpFLIP_LINENUM)
3002 sv_catpv(tmpsv, ",LINENUM");
3004 else if (o->op_type == OP_FLOP) {
3005 if (o->op_private & OPpFLIP_LINENUM)
3006 sv_catpv(tmpsv, ",LINENUM");
3008 else if (o->op_type == OP_RV2CV) {
3009 if (o->op_private & OPpLVAL_INTRO)
3010 sv_catpv(tmpsv, ",INTRO");
3012 else if (o->op_type == OP_GV) {
3013 if (o->op_private & OPpEARLY_CV)
3014 sv_catpv(tmpsv, ",EARLY_CV");
3016 else if (o->op_type == OP_LIST) {
3017 if (o->op_private & OPpLIST_GUESSED)
3018 sv_catpv(tmpsv, ",GUESSED");
3020 else if (o->op_type == OP_DELETE) {
3021 if (o->op_private & OPpSLICE)
3022 sv_catpv(tmpsv, ",SLICE");
3024 else if (o->op_type == OP_EXISTS) {
3025 if (o->op_private & OPpEXISTS_SUB)
3026 sv_catpv(tmpsv, ",EXISTS_SUB");
3028 else if (o->op_type == OP_SORT) {
3029 if (o->op_private & OPpSORT_NUMERIC)
3030 sv_catpv(tmpsv, ",NUMERIC");
3031 if (o->op_private & OPpSORT_INTEGER)
3032 sv_catpv(tmpsv, ",INTEGER");
3033 if (o->op_private & OPpSORT_REVERSE)
3034 sv_catpv(tmpsv, ",REVERSE");
3036 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
3037 if (o->op_private & OPpOPEN_IN_RAW)
3038 sv_catpv(tmpsv, ",IN_RAW");
3039 if (o->op_private & OPpOPEN_IN_CRLF)
3040 sv_catpv(tmpsv, ",IN_CRLF");
3041 if (o->op_private & OPpOPEN_OUT_RAW)
3042 sv_catpv(tmpsv, ",OUT_RAW");
3043 if (o->op_private & OPpOPEN_OUT_CRLF)
3044 sv_catpv(tmpsv, ",OUT_CRLF");
3046 else if (o->op_type == OP_EXIT) {
3047 if (o->op_private & OPpEXIT_VMSISH)
3048 sv_catpv(tmpsv, ",EXIT_VMSISH");
3049 if (o->op_private & OPpHUSH_VMSISH)
3050 sv_catpv(tmpsv, ",HUSH_VMSISH");
3052 else if (o->op_type == OP_DIE) {
3053 if (o->op_private & OPpHUSH_VMSISH)
3054 sv_catpv(tmpsv, ",HUSH_VMSISH");
3056 else if (PL_check[o->op_type] != Perl_ck_ftst) {
3057 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
3058 sv_catpv(tmpsv, ",FT_ACCESS");
3059 if (o->op_private & OPpFT_STACKED)
3060 sv_catpv(tmpsv, ",FT_STACKED");
3062 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
3063 sv_catpv(tmpsv, ",INTRO");
3065 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
3066 SvREFCNT_dec(tmpsv);
3069 switch (o->op_type) {
3071 if (o->op_flags & OPf_SPECIAL) {
3077 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3079 if (cSVOPo->op_sv) {
3080 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3081 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3087 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3088 s = SvPV(tmpsv1,len);
3089 sv_catxmlpvn(tmpsv2, s, len, 1);
3090 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3094 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3099 case OP_METHOD_NAMED:
3100 #ifndef USE_ITHREADS
3101 /* with ITHREADS, consts are stored in the pad, and the right pad
3102 * may not be active here, so skip */
3103 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3109 PerlIO_printf(file, ">\n");
3111 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3116 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3117 (UV)CopLINE(cCOPo));
3118 if (CopSTASHPV(cCOPo))
3119 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3121 if (CopLABEL(cCOPo))
3122 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3126 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3127 if (cLOOPo->op_redoop)
3128 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3130 PerlIO_printf(file, "DONE\"");
3131 S_xmldump_attr(aTHX_ level, file, "next=\"");
3132 if (cLOOPo->op_nextop)
3133 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3135 PerlIO_printf(file, "DONE\"");
3136 S_xmldump_attr(aTHX_ level, file, "last=\"");
3137 if (cLOOPo->op_lastop)
3138 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3140 PerlIO_printf(file, "DONE\"");
3148 S_xmldump_attr(aTHX_ level, file, "other=\"");
3149 if (cLOGOPo->op_other)
3150 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3152 PerlIO_printf(file, "DONE\"");
3160 if (o->op_private & OPpREFCOUNTED)
3161 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3167 if (PL_madskills && o->op_madprop) {
3168 char prevkey = '\0';
3169 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3170 const MADPROP* mp = o->op_madprop;
3174 PerlIO_printf(file, ">\n");
3176 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3179 char tmp = mp->mad_key;
3180 sv_setpvs(tmpsv,"\"");
3182 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3183 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3184 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3187 sv_catpv(tmpsv, "\"");
3188 switch (mp->mad_type) {
3190 sv_catpv(tmpsv, "NULL");
3191 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3194 sv_catpv(tmpsv, " val=\"");
3195 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3196 sv_catpv(tmpsv, "\"");
3197 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3200 sv_catpv(tmpsv, " val=\"");
3201 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3202 sv_catpv(tmpsv, "\"");
3203 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3206 if ((OP*)mp->mad_val) {
3207 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3208 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3209 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3213 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3219 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3221 SvREFCNT_dec(tmpsv);
3224 switch (o->op_type) {
3231 PerlIO_printf(file, ">\n");
3233 do_pmop_xmldump(level, file, cPMOPo);
3239 if (o->op_flags & OPf_KIDS) {
3243 PerlIO_printf(file, ">\n");
3245 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3246 do_op_xmldump(level, file, kid);
3250 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3252 PerlIO_printf(file, " />\n");
3256 Perl_op_xmldump(pTHX_ const OP *o)
3258 PERL_ARGS_ASSERT_OP_XMLDUMP;
3260 do_op_xmldump(0, PL_xmlfp, o);
3266 * c-indentation-style: bsd
3268 * indent-tabs-mode: t
3271 * ex: set ts=8 sts=4 sw=4 noet: