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), (flags) + C_ARRAY_LENGTH(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 only chars above 255 will be
236 escaped using this style, other non printable chars will use octal or
237 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
238 then all chars below 255 will be treated as printable and
239 will be output as literals.
241 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
242 string will be escaped, regardles of max. If the string is utf8 and
243 the chars value is >255 then it will be returned as a plain hex
244 sequence. Thus the output will either be a single char,
245 an octal escape sequence, a special escape like C<\n> or a 3 or
246 more digit 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;
288 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
289 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
290 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
293 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
294 "%cx{%"UVxf"}", esc, u);
295 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
298 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
302 case '\\' : /* fallthrough */
303 case '%' : if ( c == esc ) {
309 case '\v' : octbuf[1] = 'v'; break;
310 case '\t' : octbuf[1] = 't'; break;
311 case '\r' : octbuf[1] = 'r'; break;
312 case '\n' : octbuf[1] = 'n'; break;
313 case '\f' : octbuf[1] = 'f'; break;
321 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
322 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
325 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
332 if ( max && (wrote + chsize > max) ) {
334 } else if (chsize > 1) {
335 sv_catpvn(dsv, octbuf, chsize);
338 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
339 128-255 can be appended raw to the dsv. If dsv happens to be
340 UTF-8 then we need catpvf to upgrade them for us.
341 Or add a new API call sv_catpvc(). Think about that name, and
342 how to keep it clear that it's unlike the s of catpvs, which is
343 really an array octets, not a string. */
344 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
347 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
355 =for apidoc pv_pretty
357 Converts a string into something presentable, handling escaping via
358 pv_escape() and supporting quoting and ellipses.
360 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
361 double quoted with any double quotes in the string escaped. Otherwise
362 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
365 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
366 string were output then an ellipsis C<...> will be appended to the
367 string. Note that this happens AFTER it has been quoted.
369 If start_color is non-null then it will be inserted after the opening
370 quote (if there is one) but before the escaped text. If end_color
371 is non-null then it will be inserted after the escaped text but before
372 any quotes or ellipses.
374 Returns a pointer to the prettified text as held by dsv.
380 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
381 const STRLEN max, char const * const start_color, char const * const end_color,
384 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
387 PERL_ARGS_ASSERT_PV_PRETTY;
389 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
390 /* This won't alter the UTF-8 flag */
395 sv_catpvs(dsv, "\"");
396 else if ( flags & PERL_PV_PRETTY_LTGT )
399 if ( start_color != NULL )
400 sv_catpv(dsv, start_color);
402 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
404 if ( end_color != NULL )
405 sv_catpv(dsv, end_color);
408 sv_catpvs( dsv, "\"");
409 else if ( flags & PERL_PV_PRETTY_LTGT )
412 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
413 sv_catpvs(dsv, "...");
419 =for apidoc pv_display
423 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
425 except that an additional "\0" will be appended to the string when
426 len > cur and pv[cur] is "\0".
428 Note that the final string may be up to 7 chars longer than pvlim.
434 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
436 PERL_ARGS_ASSERT_PV_DISPLAY;
438 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
439 if (len > cur && pv[cur] == '\0')
440 sv_catpvs( dsv, "\\0");
445 Perl_sv_peek(pTHX_ SV *sv)
448 SV * const t = sv_newmortal();
458 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
462 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
463 if (sv == &PL_sv_undef) {
464 sv_catpv(t, "SV_UNDEF");
465 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
466 SVs_GMG|SVs_SMG|SVs_RMG)) &&
470 else if (sv == &PL_sv_no) {
471 sv_catpv(t, "SV_NO");
472 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
473 SVs_GMG|SVs_SMG|SVs_RMG)) &&
474 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
480 else if (sv == &PL_sv_yes) {
481 sv_catpv(t, "SV_YES");
482 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
483 SVs_GMG|SVs_SMG|SVs_RMG)) &&
484 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
487 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
492 sv_catpv(t, "SV_PLACEHOLDER");
493 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
494 SVs_GMG|SVs_SMG|SVs_RMG)) &&
500 else if (SvREFCNT(sv) == 0) {
504 else if (DEBUG_R_TEST_) {
507 /* is this SV on the tmps stack? */
508 for (ix=PL_tmps_ix; ix>=0; ix--) {
509 if (PL_tmps_stack[ix] == sv) {
514 if (SvREFCNT(sv) > 1)
515 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
523 if (SvCUR(t) + unref > 10) {
524 SvCUR_set(t, unref + 3);
533 if (type == SVt_PVCV) {
534 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
536 } else if (type < SVt_LAST) {
537 sv_catpv(t, svshorttypenames[type]);
539 if (type == SVt_NULL)
542 sv_catpv(t, "FREED");
547 if (!SvPVX_const(sv))
548 sv_catpv(t, "(null)");
550 SV * const tmp = newSVpvs("");
554 SvOOK_offset(sv, delta);
555 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
557 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
559 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
560 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
565 else if (SvNOKp(sv)) {
566 STORE_NUMERIC_LOCAL_SET_STANDARD();
567 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
568 RESTORE_NUMERIC_LOCAL();
570 else if (SvIOKp(sv)) {
572 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
574 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
582 if (PL_tainting && SvTAINTED(sv))
583 sv_catpv(t, " [tainted]");
584 return SvPV_nolen(t);
588 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
592 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
595 Perl_dump_indent(aTHX_ level, file, "{}\n");
598 Perl_dump_indent(aTHX_ level, file, "{\n");
600 if (pm->op_pmflags & PMf_ONCE)
605 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
606 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
607 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
609 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
610 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
611 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
612 op_dump(pm->op_pmreplrootu.op_pmreplroot);
614 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
615 SV * const tmpsv = pm_description(pm);
616 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
620 Perl_dump_indent(aTHX_ level-1, file, "}\n");
623 const struct flag_to_name pmflags_flags_names[] = {
624 {PMf_CONST, ",CONST"},
626 {PMf_GLOBAL, ",GLOBAL"},
627 {PMf_CONTINUE, ",CONTINUE"},
628 {PMf_RETAINT, ",RETAINT"},
630 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
634 S_pm_description(pTHX_ const PMOP *pm)
636 SV * const desc = newSVpvs("");
637 const REGEXP * const regex = PM_GETRE(pm);
638 const U32 pmflags = pm->op_pmflags;
640 PERL_ARGS_ASSERT_PM_DESCRIPTION;
642 if (pmflags & PMf_ONCE)
643 sv_catpv(desc, ",ONCE");
645 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
646 sv_catpv(desc, ":USED");
648 if (pmflags & PMf_USED)
649 sv_catpv(desc, ":USED");
653 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
654 sv_catpv(desc, ",TAINTED");
655 if (RX_CHECK_SUBSTR(regex)) {
656 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
657 sv_catpv(desc, ",SCANFIRST");
658 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
659 sv_catpv(desc, ",ALL");
661 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
662 sv_catpv(desc, ",SKIPWHITE");
665 append_flags(desc, pmflags, pmflags_flags_names);
670 Perl_pmop_dump(pTHX_ PMOP *pm)
672 do_pmop_dump(0, Perl_debug_log, pm);
675 /* An op sequencer. We visit the ops in the order they're to execute. */
678 S_sequence(pTHX_ register const OP *o)
681 const OP *oldop = NULL;
694 for (; o; o = o->op_next) {
696 SV * const op = newSVuv(PTR2UV(o));
697 const char * const key = SvPV_const(op, len);
699 if (hv_exists(Sequence, key, len))
702 switch (o->op_type) {
704 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
705 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
714 if (oldop && o->op_next)
721 if (oldop && o->op_next)
723 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
736 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
737 sequence_tail(cLOGOPo->op_other);
742 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
743 sequence_tail(cLOOPo->op_redoop);
744 sequence_tail(cLOOPo->op_nextop);
745 sequence_tail(cLOOPo->op_lastop);
749 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
750 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
759 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
767 S_sequence_tail(pTHX_ const OP *o)
769 while (o && (o->op_type == OP_NULL))
775 S_sequence_num(pTHX_ const OP *o)
783 op = newSVuv(PTR2UV(o));
784 key = SvPV_const(op, len);
785 seq = hv_fetch(Sequence, key, len, 0);
786 return seq ? SvUV(*seq): 0;
789 const struct flag_to_name op_flags_names[] = {
791 {OPf_PARENS, ",PARENS"},
792 {OPf_STACKED, ",STACKED"},
795 {OPf_SPECIAL, ",SPECIAL"}
798 const struct flag_to_name op_trans_names[] = {
799 {OPpTRANS_SQUASH, ",SQUASH"},
800 {OPpTRANS_DELETE, ",DELETE"},
801 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
802 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
803 {OPpTRANS_GROWS, ",GROWS"}
806 const struct flag_to_name op_entersub_names[] = {
807 {OPpENTERSUB_AMPER, ",AMPER"},
808 {OPpENTERSUB_DB, ",DB"},
809 {OPpENTERSUB_HASTARG, ",HASTARG"},
810 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
811 {OPpENTERSUB_INARGS, ",INARGS"},
812 {OPpENTERSUB_NOMOD, ",NOMOD"}
815 const struct flag_to_name op_const_names[] = {
816 {OPpCONST_BARE, ",BARE"},
817 {OPpCONST_STRICT, ",STRICT"},
818 {OPpCONST_ARYBASE, ",ARYBASE"},
819 {OPpCONST_WARNING, ",WARNING"},
820 {OPpCONST_ENTERED, ",ENTERED"}
823 const struct flag_to_name op_sort_names[] = {
824 {OPpSORT_NUMERIC, ",NUMERIC"},
825 {OPpSORT_INTEGER, ",INTEGER"},
826 {OPpSORT_REVERSE, ",REVERSE"}
829 const struct flag_to_name op_open_names[] = {
830 {OPpOPEN_IN_RAW, ",IN_RAW"},
831 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
832 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
833 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
837 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
841 const OPCODE optype = o->op_type;
843 PERL_ARGS_ASSERT_DO_OP_DUMP;
846 Perl_dump_indent(aTHX_ level, file, "{\n");
848 seq = sequence_num(o);
850 PerlIO_printf(file, "%-4"UVuf, seq);
852 PerlIO_printf(file, " ");
854 "%*sTYPE = %s ===> ",
855 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
857 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
858 sequence_num(o->op_next));
860 PerlIO_printf(file, "DONE\n");
862 if (optype == OP_NULL) {
863 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
864 if (o->op_targ == OP_NEXTSTATE) {
866 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
868 if (CopSTASHPV(cCOPo))
869 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
872 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
877 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
880 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
882 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
883 SV * const tmpsv = newSVpvs("");
884 switch (o->op_flags & OPf_WANT) {
886 sv_catpv(tmpsv, ",VOID");
888 case OPf_WANT_SCALAR:
889 sv_catpv(tmpsv, ",SCALAR");
892 sv_catpv(tmpsv, ",LIST");
895 sv_catpv(tmpsv, ",UNKNOWN");
898 append_flags(tmpsv, o->op_flags, op_flags_names);
900 sv_catpv(tmpsv, ",LATEFREE");
902 sv_catpv(tmpsv, ",LATEFREED");
904 sv_catpv(tmpsv, ",ATTACHED");
905 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
909 SV * const tmpsv = newSVpvs("");
910 if (PL_opargs[optype] & OA_TARGLEX) {
911 if (o->op_private & OPpTARGET_MY)
912 sv_catpv(tmpsv, ",TARGET_MY");
914 else if (optype == OP_LEAVESUB ||
915 optype == OP_LEAVE ||
916 optype == OP_LEAVESUBLV ||
917 optype == OP_LEAVEWRITE) {
918 if (o->op_private & OPpREFCOUNTED)
919 sv_catpv(tmpsv, ",REFCOUNTED");
921 else if (optype == OP_AASSIGN) {
922 if (o->op_private & OPpASSIGN_COMMON)
923 sv_catpv(tmpsv, ",COMMON");
925 else if (optype == OP_SASSIGN) {
926 if (o->op_private & OPpASSIGN_BACKWARDS)
927 sv_catpv(tmpsv, ",BACKWARDS");
929 else if (optype == OP_TRANS) {
930 append_flags(tmpsv, o->op_private, op_trans_names);
932 else if (optype == OP_REPEAT) {
933 if (o->op_private & OPpREPEAT_DOLIST)
934 sv_catpv(tmpsv, ",DOLIST");
936 else if (optype == OP_ENTERSUB ||
937 optype == OP_RV2SV ||
939 optype == OP_RV2AV ||
940 optype == OP_RV2HV ||
941 optype == OP_RV2GV ||
942 optype == OP_AELEM ||
945 if (optype == OP_ENTERSUB) {
946 append_flags(tmpsv, o->op_private, op_entersub_names);
949 switch (o->op_private & OPpDEREF) {
951 sv_catpv(tmpsv, ",SV");
954 sv_catpv(tmpsv, ",AV");
957 sv_catpv(tmpsv, ",HV");
960 if (o->op_private & OPpMAYBE_LVSUB)
961 sv_catpv(tmpsv, ",MAYBE_LVSUB");
964 if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
965 && (o->op_private & OPpDEREFed))
966 sv_catpv(tmpsv, ",DEREFed");
968 if (optype == OP_AELEM || optype == OP_HELEM) {
969 if (o->op_private & OPpLVAL_DEFER)
970 sv_catpv(tmpsv, ",LVAL_DEFER");
973 if (o->op_private & HINT_STRICT_REFS)
974 sv_catpv(tmpsv, ",STRICT_REFS");
975 if (o->op_private & OPpOUR_INTRO)
976 sv_catpv(tmpsv, ",OUR_INTRO");
979 else if (optype == OP_CONST) {
980 append_flags(tmpsv, o->op_private, op_const_names);
982 else if (optype == OP_FLIP) {
983 if (o->op_private & OPpFLIP_LINENUM)
984 sv_catpv(tmpsv, ",LINENUM");
986 else if (optype == OP_FLOP) {
987 if (o->op_private & OPpFLIP_LINENUM)
988 sv_catpv(tmpsv, ",LINENUM");
990 else if (optype == OP_RV2CV) {
991 if (o->op_private & OPpLVAL_INTRO)
992 sv_catpv(tmpsv, ",INTRO");
994 else if (optype == OP_GV) {
995 if (o->op_private & OPpEARLY_CV)
996 sv_catpv(tmpsv, ",EARLY_CV");
998 else if (optype == OP_LIST) {
999 if (o->op_private & OPpLIST_GUESSED)
1000 sv_catpv(tmpsv, ",GUESSED");
1002 else if (optype == OP_DELETE) {
1003 if (o->op_private & OPpSLICE)
1004 sv_catpv(tmpsv, ",SLICE");
1006 else if (optype == OP_EXISTS) {
1007 if (o->op_private & OPpEXISTS_SUB)
1008 sv_catpv(tmpsv, ",EXISTS_SUB");
1010 else if (optype == OP_SORT) {
1011 append_flags(tmpsv, o->op_private, op_sort_names);
1013 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
1014 append_flags(tmpsv, o->op_private, op_open_names);
1016 else if (optype == OP_EXIT) {
1017 if (o->op_private & OPpEXIT_VMSISH)
1018 sv_catpv(tmpsv, ",EXIT_VMSISH");
1019 if (o->op_private & OPpHUSH_VMSISH)
1020 sv_catpv(tmpsv, ",HUSH_VMSISH");
1022 else if (optype == OP_DIE) {
1023 if (o->op_private & OPpHUSH_VMSISH)
1024 sv_catpv(tmpsv, ",HUSH_VMSISH");
1026 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
1027 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1028 sv_catpv(tmpsv, ",FT_ACCESS");
1029 if (o->op_private & OPpFT_STACKED)
1030 sv_catpv(tmpsv, ",FT_STACKED");
1032 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1033 sv_catpv(tmpsv, ",INTRO");
1035 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1036 SvREFCNT_dec(tmpsv);
1040 if (PL_madskills && o->op_madprop) {
1041 SV * const tmpsv = newSVpvs("");
1042 MADPROP* mp = o->op_madprop;
1043 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1046 const char tmp = mp->mad_key;
1047 sv_setpvs(tmpsv,"'");
1049 sv_catpvn(tmpsv, &tmp, 1);
1050 sv_catpv(tmpsv, "'=");
1051 switch (mp->mad_type) {
1053 sv_catpv(tmpsv, "NULL");
1054 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1057 sv_catpv(tmpsv, "<");
1058 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1059 sv_catpv(tmpsv, ">");
1060 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1063 if ((OP*)mp->mad_val) {
1064 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1065 do_op_dump(level, file, (OP*)mp->mad_val);
1069 sv_catpv(tmpsv, "(UNK)");
1070 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1076 Perl_dump_indent(aTHX_ level, file, "}\n");
1078 SvREFCNT_dec(tmpsv);
1087 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1089 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1090 if (cSVOPo->op_sv) {
1091 SV * const tmpsv = newSV(0);
1095 /* FIXME - is this making unwarranted assumptions about the
1096 UTF-8 cleanliness of the dump file handle? */
1099 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1100 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1101 SvPV_nolen_const(tmpsv));
1105 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1111 case OP_METHOD_NAMED:
1112 #ifndef USE_ITHREADS
1113 /* with ITHREADS, consts are stored in the pad, and the right pad
1114 * may not be active here, so skip */
1115 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1121 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1122 (UV)CopLINE(cCOPo));
1123 if (CopSTASHPV(cCOPo))
1124 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1126 if (CopLABEL(cCOPo))
1127 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1131 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1132 if (cLOOPo->op_redoop)
1133 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1135 PerlIO_printf(file, "DONE\n");
1136 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1137 if (cLOOPo->op_nextop)
1138 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1140 PerlIO_printf(file, "DONE\n");
1141 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1142 if (cLOOPo->op_lastop)
1143 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1145 PerlIO_printf(file, "DONE\n");
1153 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1154 if (cLOGOPo->op_other)
1155 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1157 PerlIO_printf(file, "DONE\n");
1163 do_pmop_dump(level, file, cPMOPo);
1171 if (o->op_private & OPpREFCOUNTED)
1172 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1177 if (o->op_flags & OPf_KIDS) {
1179 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1180 do_op_dump(level, file, kid);
1182 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1186 Perl_op_dump(pTHX_ const OP *o)
1188 PERL_ARGS_ASSERT_OP_DUMP;
1189 do_op_dump(0, Perl_debug_log, o);
1193 Perl_gv_dump(pTHX_ GV *gv)
1197 PERL_ARGS_ASSERT_GV_DUMP;
1200 PerlIO_printf(Perl_debug_log, "{}\n");
1203 sv = sv_newmortal();
1204 PerlIO_printf(Perl_debug_log, "{\n");
1205 gv_fullname3(sv, gv, NULL);
1206 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1207 if (gv != GvEGV(gv)) {
1208 gv_efullname3(sv, GvEGV(gv), NULL);
1209 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1211 PerlIO_putc(Perl_debug_log, '\n');
1212 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1216 /* map magic types to the symbolic names
1217 * (with the PERL_MAGIC_ prefixed stripped)
1220 static const struct { const char type; const char *name; } magic_names[] = {
1221 { PERL_MAGIC_sv, "sv(\\0)" },
1222 { PERL_MAGIC_arylen, "arylen(#)" },
1223 { PERL_MAGIC_rhash, "rhash(%)" },
1224 { PERL_MAGIC_pos, "pos(.)" },
1225 { PERL_MAGIC_symtab, "symtab(:)" },
1226 { PERL_MAGIC_backref, "backref(<)" },
1227 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1228 { PERL_MAGIC_overload, "overload(A)" },
1229 { PERL_MAGIC_bm, "bm(B)" },
1230 { PERL_MAGIC_regdata, "regdata(D)" },
1231 { PERL_MAGIC_env, "env(E)" },
1232 { PERL_MAGIC_hints, "hints(H)" },
1233 { PERL_MAGIC_isa, "isa(I)" },
1234 { PERL_MAGIC_dbfile, "dbfile(L)" },
1235 { PERL_MAGIC_shared, "shared(N)" },
1236 { PERL_MAGIC_tied, "tied(P)" },
1237 { PERL_MAGIC_sig, "sig(S)" },
1238 { PERL_MAGIC_uvar, "uvar(U)" },
1239 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1240 { PERL_MAGIC_overload_table, "overload_table(c)" },
1241 { PERL_MAGIC_regdatum, "regdatum(d)" },
1242 { PERL_MAGIC_envelem, "envelem(e)" },
1243 { PERL_MAGIC_fm, "fm(f)" },
1244 { PERL_MAGIC_regex_global, "regex_global(g)" },
1245 { PERL_MAGIC_hintselem, "hintselem(h)" },
1246 { PERL_MAGIC_isaelem, "isaelem(i)" },
1247 { PERL_MAGIC_nkeys, "nkeys(k)" },
1248 { PERL_MAGIC_dbline, "dbline(l)" },
1249 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1250 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1251 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1252 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1253 { PERL_MAGIC_qr, "qr(r)" },
1254 { PERL_MAGIC_sigelem, "sigelem(s)" },
1255 { PERL_MAGIC_taint, "taint(t)" },
1256 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1257 { PERL_MAGIC_vec, "vec(v)" },
1258 { PERL_MAGIC_vstring, "vstring(V)" },
1259 { PERL_MAGIC_utf8, "utf8(w)" },
1260 { PERL_MAGIC_substr, "substr(x)" },
1261 { PERL_MAGIC_defelem, "defelem(y)" },
1262 { PERL_MAGIC_ext, "ext(~)" },
1263 /* this null string terminates the list */
1268 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1270 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1272 for (; mg; mg = mg->mg_moremagic) {
1273 Perl_dump_indent(aTHX_ level, file,
1274 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1275 if (mg->mg_virtual) {
1276 const MGVTBL * const v = mg->mg_virtual;
1278 if (v == &PL_vtbl_sv) s = "sv";
1279 else if (v == &PL_vtbl_env) s = "env";
1280 else if (v == &PL_vtbl_envelem) s = "envelem";
1281 else if (v == &PL_vtbl_sig) s = "sig";
1282 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1283 else if (v == &PL_vtbl_pack) s = "pack";
1284 else if (v == &PL_vtbl_packelem) s = "packelem";
1285 else if (v == &PL_vtbl_dbline) s = "dbline";
1286 else if (v == &PL_vtbl_isa) s = "isa";
1287 else if (v == &PL_vtbl_arylen) s = "arylen";
1288 else if (v == &PL_vtbl_mglob) s = "mglob";
1289 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1290 else if (v == &PL_vtbl_taint) s = "taint";
1291 else if (v == &PL_vtbl_substr) s = "substr";
1292 else if (v == &PL_vtbl_vec) s = "vec";
1293 else if (v == &PL_vtbl_pos) s = "pos";
1294 else if (v == &PL_vtbl_bm) s = "bm";
1295 else if (v == &PL_vtbl_fm) s = "fm";
1296 else if (v == &PL_vtbl_uvar) s = "uvar";
1297 else if (v == &PL_vtbl_defelem) s = "defelem";
1298 #ifdef USE_LOCALE_COLLATE
1299 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1301 else if (v == &PL_vtbl_amagic) s = "amagic";
1302 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1303 else if (v == &PL_vtbl_backref) s = "backref";
1304 else if (v == &PL_vtbl_utf8) s = "utf8";
1305 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1306 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1307 else if (v == &PL_vtbl_hints) s = "hints";
1310 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1312 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1315 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1318 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1322 const char *name = NULL;
1323 for (n = 0; magic_names[n].name; n++) {
1324 if (mg->mg_type == magic_names[n].type) {
1325 name = magic_names[n].name;
1330 Perl_dump_indent(aTHX_ level, file,
1331 " MG_TYPE = PERL_MAGIC_%s\n", name);
1333 Perl_dump_indent(aTHX_ level, file,
1334 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1338 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1339 if (mg->mg_type == PERL_MAGIC_envelem &&
1340 mg->mg_flags & MGf_TAINTEDDIR)
1341 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1342 if (mg->mg_flags & MGf_REFCOUNTED)
1343 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1344 if (mg->mg_flags & MGf_GSKIP)
1345 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1346 if (mg->mg_type == PERL_MAGIC_regex_global &&
1347 mg->mg_flags & MGf_MINMATCH)
1348 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1351 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1352 PTR2UV(mg->mg_obj));
1353 if (mg->mg_type == PERL_MAGIC_qr) {
1354 REGEXP* const re = (REGEXP *)mg->mg_obj;
1355 SV * const dsv = sv_newmortal();
1356 const char * const s
1357 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1359 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1360 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1362 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1363 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1366 if (mg->mg_flags & MGf_REFCOUNTED)
1367 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1370 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1372 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1373 if (mg->mg_len >= 0) {
1374 if (mg->mg_type != PERL_MAGIC_utf8) {
1375 SV * const sv = newSVpvs("");
1376 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1380 else if (mg->mg_len == HEf_SVKEY) {
1381 PerlIO_puts(file, " => HEf_SVKEY\n");
1382 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1383 maxnest, dumpops, pvlim); /* MG is already +1 */
1386 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1391 " does not know how to handle this MG_LEN"
1393 PerlIO_putc(file, '\n');
1395 if (mg->mg_type == PERL_MAGIC_utf8) {
1396 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1399 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1400 Perl_dump_indent(aTHX_ level, file,
1401 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1404 (UV)cache[i * 2 + 1]);
1411 Perl_magic_dump(pTHX_ const MAGIC *mg)
1413 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1417 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1421 PERL_ARGS_ASSERT_DO_HV_DUMP;
1423 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1424 if (sv && (hvname = HvNAME_get(sv)))
1425 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1427 PerlIO_putc(file, '\n');
1431 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1433 PERL_ARGS_ASSERT_DO_GV_DUMP;
1435 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1436 if (sv && GvNAME(sv))
1437 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1439 PerlIO_putc(file, '\n');
1443 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1445 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1447 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1448 if (sv && GvNAME(sv)) {
1450 PerlIO_printf(file, "\t\"");
1451 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1452 PerlIO_printf(file, "%s\" :: \"", hvname);
1453 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1456 PerlIO_putc(file, '\n');
1459 const struct flag_to_name first_sv_flags_names[] = {
1460 {SVs_TEMP, "TEMP,"},
1461 {SVs_OBJECT, "OBJECT,"},
1470 const struct flag_to_name second_sv_flags_names[] = {
1472 {SVf_FAKE, "FAKE,"},
1473 {SVf_READONLY, "READONLY,"},
1474 {SVf_BREAK, "BREAK,"},
1475 {SVf_AMAGIC, "OVERLOAD,"},
1481 const struct flag_to_name cv_flags_names[] = {
1482 {CVf_ANON, "ANON,"},
1483 {CVf_UNIQUE, "UNIQUE,"},
1484 {CVf_CLONE, "CLONE,"},
1485 {CVf_CLONED, "CLONED,"},
1486 {CVf_CONST, "CONST,"},
1487 {CVf_NODEBUG, "NODEBUG,"},
1488 {CVf_LVALUE, "LVALUE,"},
1489 {CVf_METHOD, "METHOD,"},
1490 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"}
1493 const struct flag_to_name hv_flags_names[] = {
1494 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1495 {SVphv_LAZYDEL, "LAZYDEL,"},
1496 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1497 {SVphv_REHASH, "REHASH,"},
1498 {SVphv_CLONEABLE, "CLONEABLE,"}
1501 const struct flag_to_name gp_flags_names[] = {
1502 {GVf_INTRO, "INTRO,"},
1503 {GVf_MULTI, "MULTI,"},
1504 {GVf_ASSUMECV, "ASSUMECV,"},
1505 {GVf_IN_PAD, "IN_PAD,"}
1508 const struct flag_to_name gp_flags_imported_names[] = {
1509 {GVf_IMPORTED_SV, " SV"},
1510 {GVf_IMPORTED_AV, " AV"},
1511 {GVf_IMPORTED_HV, " HV"},
1512 {GVf_IMPORTED_CV, " CV"},
1516 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1524 PERL_ARGS_ASSERT_DO_SV_DUMP;
1527 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1531 flags = SvFLAGS(sv);
1534 d = Perl_newSVpvf(aTHX_
1535 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1536 PTR2UV(SvANY(sv)), PTR2UV(sv),
1537 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1538 (int)(PL_dumpindent*level), "");
1540 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1541 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1543 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1544 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1545 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1547 append_flags(d, flags, first_sv_flags_names);
1548 if (flags & SVf_ROK) {
1549 sv_catpv(d, "ROK,");
1550 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1552 append_flags(d, flags, second_sv_flags_names);
1553 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1554 if (SvPCS_IMPORTED(sv))
1555 sv_catpv(d, "PCS_IMPORTED,");
1557 sv_catpv(d, "SCREAM,");
1563 append_flags(d, CvFLAGS(sv), cv_flags_names);
1564 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1567 append_flags(d, flags, hv_flags_names);
1571 if (isGV_with_GP(sv)) {
1572 append_flags(d, GvFLAGS(sv), gp_flags_names);
1574 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1575 sv_catpv(d, "IMPORT");
1576 if (GvIMPORTED(sv) == GVf_IMPORTED)
1577 sv_catpv(d, "ALL,");
1580 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1584 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1585 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1589 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1590 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1593 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1594 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1597 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1602 /* SVphv_SHAREKEYS is also 0x20000000 */
1603 if ((type != SVt_PVHV) && SvUTF8(sv))
1604 sv_catpv(d, "UTF8");
1606 if (*(SvEND(d) - 1) == ',') {
1607 SvCUR_set(d, SvCUR(d) - 1);
1608 SvPVX(d)[SvCUR(d)] = '\0';
1613 #ifdef DEBUG_LEAKING_SCALARS
1614 Perl_dump_indent(aTHX_ level, file,
1615 "ALLOCATED at %s:%d %s %s%s; serial %"UVuf"\n",
1616 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1618 sv->sv_debug_inpad ? "for" : "by",
1619 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1620 sv->sv_debug_cloned ? " (cloned)" : "",
1624 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);
1637 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1638 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM
1639 && type != SVt_PVIO && type != SVt_REGEXP)
1640 || (type == SVt_IV && !SvROK(sv))) {
1642 #ifdef PERL_OLD_COPY_ON_WRITE
1646 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1648 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1649 #ifdef PERL_OLD_COPY_ON_WRITE
1650 if (SvIsCOW_shared_hash(sv))
1651 PerlIO_printf(file, " (HASH)");
1652 else if (SvIsCOW_normal(sv))
1653 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1655 PerlIO_putc(file, '\n');
1657 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1658 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1659 (UV) COP_SEQ_RANGE_LOW(sv));
1660 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1661 (UV) COP_SEQ_RANGE_HIGH(sv));
1662 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1663 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1664 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1665 || type == SVt_NV) {
1666 STORE_NUMERIC_LOCAL_SET_STANDARD();
1667 /* %Vg doesn't work? --jhi */
1668 #ifdef USE_LONG_DOUBLE
1669 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1671 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1673 RESTORE_NUMERIC_LOCAL();
1676 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1678 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1680 if (type < SVt_PV) {
1684 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1685 if (SvPVX_const(sv)) {
1688 SvOOK_offset(sv, delta);
1689 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1694 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1696 PerlIO_printf(file, "( %s . ) ",
1697 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1700 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1701 if (SvUTF8(sv)) /* the 6? \x{....} */
1702 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1703 PerlIO_printf(file, "\n");
1704 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1705 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1708 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1710 if (type == SVt_REGEXP) {
1712 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1713 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1716 if (type >= SVt_PVMG) {
1717 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1718 HV * const ost = SvOURSTASH(sv);
1720 do_hv_dump(level, file, " OURSTASH", ost);
1723 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1726 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1730 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1731 if (AvARRAY(sv) != AvALLOC(sv)) {
1732 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1733 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1736 PerlIO_putc(file, '\n');
1737 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1738 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1739 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1741 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1742 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1743 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1744 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1745 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1747 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1748 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1750 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1752 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1757 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1758 if (HvARRAY(sv) && HvKEYS(sv)) {
1759 /* Show distribution of HEs in the ARRAY */
1761 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1764 U32 pow2 = 2, keys = HvKEYS(sv);
1765 NV theoret, sum = 0;
1767 PerlIO_printf(file, " (");
1768 Zero(freq, FREQ_MAX + 1, int);
1769 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1772 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1774 if (count > FREQ_MAX)
1780 for (i = 0; i <= max; i++) {
1782 PerlIO_printf(file, "%d%s:%d", i,
1783 (i == FREQ_MAX) ? "+" : "",
1786 PerlIO_printf(file, ", ");
1789 PerlIO_putc(file, ')');
1790 /* The "quality" of a hash is defined as the total number of
1791 comparisons needed to access every element once, relative
1792 to the expected number needed for a random hash.
1794 The total number of comparisons is equal to the sum of
1795 the squares of the number of entries in each bucket.
1796 For a random hash of n keys into k buckets, the expected
1801 for (i = max; i > 0; i--) { /* Precision: count down. */
1802 sum += freq[i] * i * i;
1804 while ((keys = keys >> 1))
1806 theoret = HvKEYS(sv);
1807 theoret += theoret * (theoret-1)/pow2;
1808 PerlIO_putc(file, '\n');
1809 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1811 PerlIO_putc(file, '\n');
1812 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1813 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1814 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1815 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1816 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1818 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1819 if (mg && mg->mg_obj) {
1820 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1824 const char * const hvname = HvNAME_get(sv);
1826 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1830 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1831 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1833 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1835 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1839 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1840 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1841 (int)meta->mro_which->length,
1842 meta->mro_which->name,
1843 PTR2UV(meta->mro_which));
1844 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1845 (UV)meta->cache_gen);
1846 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1848 if (meta->mro_linear_all) {
1849 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1850 PTR2UV(meta->mro_linear_all));
1851 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1854 if (meta->mro_linear_current) {
1855 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1856 PTR2UV(meta->mro_linear_current));
1857 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1860 if (meta->mro_nextmethod) {
1861 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1862 PTR2UV(meta->mro_nextmethod));
1863 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1867 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1869 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1874 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1876 HV * const hv = MUTABLE_HV(sv);
1877 int count = maxnest - nest;
1880 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1883 const U32 hash = HeHASH(he);
1884 SV * const keysv = hv_iterkeysv(he);
1885 const char * const keypv = SvPV_const(keysv, len);
1886 SV * const elt = hv_iterval(hv, he);
1888 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1890 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1892 PerlIO_printf(file, "[REHASH] ");
1893 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1894 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1896 hv_iterinit(hv); /* Return to status quo */
1902 const char *const proto = SvPV_const(sv, len);
1903 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1908 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1909 if (!CvISXSUB(sv)) {
1911 Perl_dump_indent(aTHX_ level, file,
1912 " START = 0x%"UVxf" ===> %"IVdf"\n",
1913 PTR2UV(CvSTART(sv)),
1914 (IV)sequence_num(CvSTART(sv)));
1916 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1917 PTR2UV(CvROOT(sv)));
1918 if (CvROOT(sv) && dumpops) {
1919 do_op_dump(level+1, file, CvROOT(sv));
1922 SV * const constant = cv_const_sv((const CV *)sv);
1924 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1927 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1929 PTR2UV(CvXSUBANY(sv).any_ptr));
1930 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1933 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1934 (IV)CvXSUBANY(sv).any_i32);
1937 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1938 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1939 if (type == SVt_PVCV)
1940 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1941 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1942 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1943 if (type == SVt_PVFM)
1944 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1945 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1946 if (nest < maxnest) {
1947 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1950 const CV * const outside = CvOUTSIDE(sv);
1951 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1954 : CvANON(outside) ? "ANON"
1955 : (outside == PL_main_cv) ? "MAIN"
1956 : CvUNIQUE(outside) ? "UNIQUE"
1957 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1959 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1960 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1964 if (type == SVt_PVLV) {
1965 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1966 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1967 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1968 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1969 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1970 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1974 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1975 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1976 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1977 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1979 if (!isGV_with_GP(sv))
1981 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1982 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1983 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1984 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1987 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1988 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1989 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1990 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1991 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1992 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1993 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1994 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1995 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1996 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1997 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1998 do_gv_dump (level, file, " EGV", GvEGV(sv));
2001 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2002 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2003 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2004 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2005 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2006 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2007 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2009 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2010 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2011 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2013 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2014 PTR2UV(IoTOP_GV(sv)));
2015 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2016 maxnest, dumpops, pvlim);
2018 /* Source filters hide things that are not GVs in these three, so let's
2019 be careful out there. */
2021 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2022 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2023 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2025 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2026 PTR2UV(IoFMT_GV(sv)));
2027 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2028 maxnest, dumpops, pvlim);
2030 if (IoBOTTOM_NAME(sv))
2031 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2032 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2033 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2035 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2036 PTR2UV(IoBOTTOM_GV(sv)));
2037 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2038 maxnest, dumpops, pvlim);
2040 if (isPRINT(IoTYPE(sv)))
2041 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2043 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2044 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2051 Perl_sv_dump(pTHX_ SV *sv)
2055 PERL_ARGS_ASSERT_SV_DUMP;
2058 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2060 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2064 Perl_runops_debug(pTHX)
2068 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2072 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2075 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2076 PerlIO_printf(Perl_debug_log,
2077 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2078 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2079 PTR2UV(*PL_watchaddr));
2080 if (DEBUG_s_TEST_) {
2081 if (DEBUG_v_TEST_) {
2082 PerlIO_printf(Perl_debug_log, "\n");
2090 if (DEBUG_t_TEST_) debop(PL_op);
2091 if (DEBUG_P_TEST_) debprof(PL_op);
2093 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2094 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2101 Perl_debop(pTHX_ const OP *o)
2105 PERL_ARGS_ASSERT_DEBOP;
2107 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2110 Perl_deb(aTHX_ "%s", OP_NAME(o));
2111 switch (o->op_type) {
2114 /* With ITHREADS, consts are stored in the pad, and the right pad
2115 * may not be active here, so check.
2116 * Looks like only during compiling the pads are illegal.
2119 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2121 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2126 SV * const sv = newSV(0);
2128 /* FIXME - is this making unwarranted assumptions about the
2129 UTF-8 cleanliness of the dump file handle? */
2132 gv_fullname3(sv, cGVOPo_gv, NULL);
2133 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2137 PerlIO_printf(Perl_debug_log, "(NULL)");
2143 /* print the lexical's name */
2144 CV * const cv = deb_curcv(cxstack_ix);
2147 AV * const padlist = CvPADLIST(cv);
2148 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2149 sv = *av_fetch(comppad, o->op_targ, FALSE);
2153 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2155 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2161 PerlIO_printf(Perl_debug_log, "\n");
2166 S_deb_curcv(pTHX_ const I32 ix)
2169 const PERL_CONTEXT * const cx = &cxstack[ix];
2170 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2171 return cx->blk_sub.cv;
2172 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2174 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2179 return deb_curcv(ix - 1);
2183 Perl_watch(pTHX_ char **addr)
2187 PERL_ARGS_ASSERT_WATCH;
2189 PL_watchaddr = addr;
2191 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2192 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2196 S_debprof(pTHX_ const OP *o)
2200 PERL_ARGS_ASSERT_DEBPROF;
2202 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2204 if (!PL_profiledata)
2205 Newxz(PL_profiledata, MAXO, U32);
2206 ++PL_profiledata[o->op_type];
2210 Perl_debprofdump(pTHX)
2214 if (!PL_profiledata)
2216 for (i = 0; i < MAXO; i++) {
2217 if (PL_profiledata[i])
2218 PerlIO_printf(Perl_debug_log,
2219 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2226 * XML variants of most of the above routines
2230 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2234 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2236 PerlIO_printf(file, "\n ");
2237 va_start(args, pat);
2238 xmldump_vindent(level, file, pat, &args);
2244 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2247 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2248 va_start(args, pat);
2249 xmldump_vindent(level, file, pat, &args);
2254 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2256 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2258 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2259 PerlIO_vprintf(file, pat, *args);
2263 Perl_xmldump_all(pTHX)
2265 xmldump_all_perl(FALSE);
2269 Perl_xmldump_all_perl(pTHX_ bool justperl)
2271 PerlIO_setlinebuf(PL_xmlfp);
2273 op_xmldump(PL_main_root);
2274 xmldump_packsubs_perl(PL_defstash, justperl);
2275 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2276 PerlIO_close(PL_xmlfp);
2281 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2283 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2284 xmldump_packsubs_perl(stash, FALSE);
2288 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2293 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2295 if (!HvARRAY(stash))
2297 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2298 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2299 GV *gv = MUTABLE_GV(HeVAL(entry));
2301 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2304 xmldump_sub_perl(gv, justperl);
2307 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2308 && (hv = GvHV(gv)) && hv != PL_defstash)
2309 xmldump_packsubs_perl(hv, justperl); /* nested package */
2315 Perl_xmldump_sub(pTHX_ const GV *gv)
2317 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2318 xmldump_sub_perl(gv, FALSE);
2322 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2326 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2328 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2331 sv = sv_newmortal();
2332 gv_fullname3(sv, gv, NULL);
2333 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2334 if (CvXSUB(GvCV(gv)))
2335 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2336 PTR2UV(CvXSUB(GvCV(gv))),
2337 (int)CvXSUBANY(GvCV(gv)).any_i32);
2338 else if (CvROOT(GvCV(gv)))
2339 op_xmldump(CvROOT(GvCV(gv)));
2341 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2345 Perl_xmldump_form(pTHX_ const GV *gv)
2347 SV * const sv = sv_newmortal();
2349 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2351 gv_fullname3(sv, gv, NULL);
2352 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2353 if (CvROOT(GvFORM(gv)))
2354 op_xmldump(CvROOT(GvFORM(gv)));
2356 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2360 Perl_xmldump_eval(pTHX)
2362 op_xmldump(PL_eval_root);
2366 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2368 PERL_ARGS_ASSERT_SV_CATXMLSV;
2369 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2373 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2376 const char * const e = pv + len;
2377 const char * const start = pv;
2381 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2384 dsvcur = SvCUR(dsv); /* in case we have to restart */
2389 c = utf8_to_uvchr((U8*)pv, &cl);
2391 SvCUR(dsv) = dsvcur;
2456 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2459 sv_catpvs(dsv, "<");
2462 sv_catpvs(dsv, ">");
2465 sv_catpvs(dsv, "&");
2468 sv_catpvs(dsv, """);
2472 if (c < 32 || c > 127) {
2473 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2476 const char string = (char) c;
2477 sv_catpvn(dsv, &string, 1);
2481 if ((c >= 0xD800 && c <= 0xDB7F) ||
2482 (c >= 0xDC00 && c <= 0xDFFF) ||
2483 (c >= 0xFFF0 && c <= 0xFFFF) ||
2485 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2487 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2500 Perl_sv_xmlpeek(pTHX_ SV *sv)
2502 SV * const t = sv_newmortal();
2506 PERL_ARGS_ASSERT_SV_XMLPEEK;
2512 sv_catpv(t, "VOID=\"\"");
2515 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2516 sv_catpv(t, "WILD=\"\"");
2519 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2520 if (sv == &PL_sv_undef) {
2521 sv_catpv(t, "SV_UNDEF=\"1\"");
2522 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2523 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2527 else if (sv == &PL_sv_no) {
2528 sv_catpv(t, "SV_NO=\"1\"");
2529 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2530 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2531 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2532 SVp_POK|SVp_NOK)) &&
2537 else if (sv == &PL_sv_yes) {
2538 sv_catpv(t, "SV_YES=\"1\"");
2539 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2540 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2541 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2542 SVp_POK|SVp_NOK)) &&
2544 SvPVX(sv) && *SvPVX(sv) == '1' &&
2549 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2550 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2551 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2555 sv_catpv(t, " XXX=\"\" ");
2557 else if (SvREFCNT(sv) == 0) {
2558 sv_catpv(t, " refcnt=\"0\"");
2561 else if (DEBUG_R_TEST_) {
2564 /* is this SV on the tmps stack? */
2565 for (ix=PL_tmps_ix; ix>=0; ix--) {
2566 if (PL_tmps_stack[ix] == sv) {
2571 if (SvREFCNT(sv) > 1)
2572 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2575 sv_catpv(t, " DRT=\"<T>\"");
2579 sv_catpv(t, " ROK=\"\"");
2581 switch (SvTYPE(sv)) {
2583 sv_catpv(t, " FREED=\"1\"");
2587 sv_catpv(t, " UNDEF=\"1\"");
2590 sv_catpv(t, " IV=\"");
2593 sv_catpv(t, " NV=\"");
2596 sv_catpv(t, " PV=\"");
2599 sv_catpv(t, " PVIV=\"");
2602 sv_catpv(t, " PVNV=\"");
2605 sv_catpv(t, " PVMG=\"");
2608 sv_catpv(t, " PVLV=\"");
2611 sv_catpv(t, " AV=\"");
2614 sv_catpv(t, " HV=\"");
2618 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2620 sv_catpv(t, " CV=\"()\"");
2623 sv_catpv(t, " GV=\"");
2626 sv_catpv(t, " BIND=\"");
2629 sv_catpv(t, " ORANGE=\"");
2632 sv_catpv(t, " FM=\"");
2635 sv_catpv(t, " IO=\"");
2644 else if (SvNOKp(sv)) {
2645 STORE_NUMERIC_LOCAL_SET_STANDARD();
2646 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2647 RESTORE_NUMERIC_LOCAL();
2649 else if (SvIOKp(sv)) {
2651 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2653 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2662 return SvPV(t, n_a);
2666 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2668 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2671 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2674 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2677 REGEXP *const r = PM_GETRE(pm);
2678 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2679 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2680 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2682 SvREFCNT_dec(tmpsv);
2683 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2684 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2687 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2688 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2689 SV * const tmpsv = pm_description(pm);
2690 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2691 SvREFCNT_dec(tmpsv);
2695 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2696 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2697 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2698 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2699 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2700 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2703 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2707 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2709 do_pmop_xmldump(0, PL_xmlfp, pm);
2713 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2718 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2723 seq = sequence_num(o);
2724 Perl_xmldump_indent(aTHX_ level, file,
2725 "<op_%s seq=\"%"UVuf" -> ",
2730 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2731 sequence_num(o->op_next));
2733 PerlIO_printf(file, "DONE\"");
2736 if (o->op_type == OP_NULL)
2738 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2739 if (o->op_targ == OP_NEXTSTATE)
2742 PerlIO_printf(file, " line=\"%"UVuf"\"",
2743 (UV)CopLINE(cCOPo));
2744 if (CopSTASHPV(cCOPo))
2745 PerlIO_printf(file, " package=\"%s\"",
2747 if (CopLABEL(cCOPo))
2748 PerlIO_printf(file, " label=\"%s\"",
2753 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2756 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2759 SV * const tmpsv = newSVpvs("");
2760 switch (o->op_flags & OPf_WANT) {
2762 sv_catpv(tmpsv, ",VOID");
2764 case OPf_WANT_SCALAR:
2765 sv_catpv(tmpsv, ",SCALAR");
2768 sv_catpv(tmpsv, ",LIST");
2771 sv_catpv(tmpsv, ",UNKNOWN");
2774 if (o->op_flags & OPf_KIDS)
2775 sv_catpv(tmpsv, ",KIDS");
2776 if (o->op_flags & OPf_PARENS)
2777 sv_catpv(tmpsv, ",PARENS");
2778 if (o->op_flags & OPf_STACKED)
2779 sv_catpv(tmpsv, ",STACKED");
2780 if (o->op_flags & OPf_REF)
2781 sv_catpv(tmpsv, ",REF");
2782 if (o->op_flags & OPf_MOD)
2783 sv_catpv(tmpsv, ",MOD");
2784 if (o->op_flags & OPf_SPECIAL)
2785 sv_catpv(tmpsv, ",SPECIAL");
2786 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2787 SvREFCNT_dec(tmpsv);
2789 if (o->op_private) {
2790 SV * const tmpsv = newSVpvs("");
2791 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2792 if (o->op_private & OPpTARGET_MY)
2793 sv_catpv(tmpsv, ",TARGET_MY");
2795 else if (o->op_type == OP_LEAVESUB ||
2796 o->op_type == OP_LEAVE ||
2797 o->op_type == OP_LEAVESUBLV ||
2798 o->op_type == OP_LEAVEWRITE) {
2799 if (o->op_private & OPpREFCOUNTED)
2800 sv_catpv(tmpsv, ",REFCOUNTED");
2802 else if (o->op_type == OP_AASSIGN) {
2803 if (o->op_private & OPpASSIGN_COMMON)
2804 sv_catpv(tmpsv, ",COMMON");
2806 else if (o->op_type == OP_SASSIGN) {
2807 if (o->op_private & OPpASSIGN_BACKWARDS)
2808 sv_catpv(tmpsv, ",BACKWARDS");
2810 else if (o->op_type == OP_TRANS) {
2811 if (o->op_private & OPpTRANS_SQUASH)
2812 sv_catpv(tmpsv, ",SQUASH");
2813 if (o->op_private & OPpTRANS_DELETE)
2814 sv_catpv(tmpsv, ",DELETE");
2815 if (o->op_private & OPpTRANS_COMPLEMENT)
2816 sv_catpv(tmpsv, ",COMPLEMENT");
2817 if (o->op_private & OPpTRANS_IDENTICAL)
2818 sv_catpv(tmpsv, ",IDENTICAL");
2819 if (o->op_private & OPpTRANS_GROWS)
2820 sv_catpv(tmpsv, ",GROWS");
2822 else if (o->op_type == OP_REPEAT) {
2823 if (o->op_private & OPpREPEAT_DOLIST)
2824 sv_catpv(tmpsv, ",DOLIST");
2826 else if (o->op_type == OP_ENTERSUB ||
2827 o->op_type == OP_RV2SV ||
2828 o->op_type == OP_GVSV ||
2829 o->op_type == OP_RV2AV ||
2830 o->op_type == OP_RV2HV ||
2831 o->op_type == OP_RV2GV ||
2832 o->op_type == OP_AELEM ||
2833 o->op_type == OP_HELEM )
2835 if (o->op_type == OP_ENTERSUB) {
2836 if (o->op_private & OPpENTERSUB_AMPER)
2837 sv_catpv(tmpsv, ",AMPER");
2838 if (o->op_private & OPpENTERSUB_DB)
2839 sv_catpv(tmpsv, ",DB");
2840 if (o->op_private & OPpENTERSUB_HASTARG)
2841 sv_catpv(tmpsv, ",HASTARG");
2842 if (o->op_private & OPpENTERSUB_NOPAREN)
2843 sv_catpv(tmpsv, ",NOPAREN");
2844 if (o->op_private & OPpENTERSUB_INARGS)
2845 sv_catpv(tmpsv, ",INARGS");
2846 if (o->op_private & OPpENTERSUB_NOMOD)
2847 sv_catpv(tmpsv, ",NOMOD");
2850 switch (o->op_private & OPpDEREF) {
2852 sv_catpv(tmpsv, ",SV");
2855 sv_catpv(tmpsv, ",AV");
2858 sv_catpv(tmpsv, ",HV");
2861 if (o->op_private & OPpMAYBE_LVSUB)
2862 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2864 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2865 if (o->op_private & OPpLVAL_DEFER)
2866 sv_catpv(tmpsv, ",LVAL_DEFER");
2869 if (o->op_private & HINT_STRICT_REFS)
2870 sv_catpv(tmpsv, ",STRICT_REFS");
2871 if (o->op_private & OPpOUR_INTRO)
2872 sv_catpv(tmpsv, ",OUR_INTRO");
2875 else if (o->op_type == OP_CONST) {
2876 if (o->op_private & OPpCONST_BARE)
2877 sv_catpv(tmpsv, ",BARE");
2878 if (o->op_private & OPpCONST_STRICT)
2879 sv_catpv(tmpsv, ",STRICT");
2880 if (o->op_private & OPpCONST_ARYBASE)
2881 sv_catpv(tmpsv, ",ARYBASE");
2882 if (o->op_private & OPpCONST_WARNING)
2883 sv_catpv(tmpsv, ",WARNING");
2884 if (o->op_private & OPpCONST_ENTERED)
2885 sv_catpv(tmpsv, ",ENTERED");
2887 else if (o->op_type == OP_FLIP) {
2888 if (o->op_private & OPpFLIP_LINENUM)
2889 sv_catpv(tmpsv, ",LINENUM");
2891 else if (o->op_type == OP_FLOP) {
2892 if (o->op_private & OPpFLIP_LINENUM)
2893 sv_catpv(tmpsv, ",LINENUM");
2895 else if (o->op_type == OP_RV2CV) {
2896 if (o->op_private & OPpLVAL_INTRO)
2897 sv_catpv(tmpsv, ",INTRO");
2899 else if (o->op_type == OP_GV) {
2900 if (o->op_private & OPpEARLY_CV)
2901 sv_catpv(tmpsv, ",EARLY_CV");
2903 else if (o->op_type == OP_LIST) {
2904 if (o->op_private & OPpLIST_GUESSED)
2905 sv_catpv(tmpsv, ",GUESSED");
2907 else if (o->op_type == OP_DELETE) {
2908 if (o->op_private & OPpSLICE)
2909 sv_catpv(tmpsv, ",SLICE");
2911 else if (o->op_type == OP_EXISTS) {
2912 if (o->op_private & OPpEXISTS_SUB)
2913 sv_catpv(tmpsv, ",EXISTS_SUB");
2915 else if (o->op_type == OP_SORT) {
2916 if (o->op_private & OPpSORT_NUMERIC)
2917 sv_catpv(tmpsv, ",NUMERIC");
2918 if (o->op_private & OPpSORT_INTEGER)
2919 sv_catpv(tmpsv, ",INTEGER");
2920 if (o->op_private & OPpSORT_REVERSE)
2921 sv_catpv(tmpsv, ",REVERSE");
2923 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2924 if (o->op_private & OPpOPEN_IN_RAW)
2925 sv_catpv(tmpsv, ",IN_RAW");
2926 if (o->op_private & OPpOPEN_IN_CRLF)
2927 sv_catpv(tmpsv, ",IN_CRLF");
2928 if (o->op_private & OPpOPEN_OUT_RAW)
2929 sv_catpv(tmpsv, ",OUT_RAW");
2930 if (o->op_private & OPpOPEN_OUT_CRLF)
2931 sv_catpv(tmpsv, ",OUT_CRLF");
2933 else if (o->op_type == OP_EXIT) {
2934 if (o->op_private & OPpEXIT_VMSISH)
2935 sv_catpv(tmpsv, ",EXIT_VMSISH");
2936 if (o->op_private & OPpHUSH_VMSISH)
2937 sv_catpv(tmpsv, ",HUSH_VMSISH");
2939 else if (o->op_type == OP_DIE) {
2940 if (o->op_private & OPpHUSH_VMSISH)
2941 sv_catpv(tmpsv, ",HUSH_VMSISH");
2943 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2944 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2945 sv_catpv(tmpsv, ",FT_ACCESS");
2946 if (o->op_private & OPpFT_STACKED)
2947 sv_catpv(tmpsv, ",FT_STACKED");
2949 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2950 sv_catpv(tmpsv, ",INTRO");
2952 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2953 SvREFCNT_dec(tmpsv);
2956 switch (o->op_type) {
2958 if (o->op_flags & OPf_SPECIAL) {
2964 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2966 if (cSVOPo->op_sv) {
2967 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2968 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2974 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2975 s = SvPV(tmpsv1,len);
2976 sv_catxmlpvn(tmpsv2, s, len, 1);
2977 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2981 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2986 case OP_METHOD_NAMED:
2987 #ifndef USE_ITHREADS
2988 /* with ITHREADS, consts are stored in the pad, and the right pad
2989 * may not be active here, so skip */
2990 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2996 PerlIO_printf(file, ">\n");
2998 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3003 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3004 (UV)CopLINE(cCOPo));
3005 if (CopSTASHPV(cCOPo))
3006 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3008 if (CopLABEL(cCOPo))
3009 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3013 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3014 if (cLOOPo->op_redoop)
3015 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3017 PerlIO_printf(file, "DONE\"");
3018 S_xmldump_attr(aTHX_ level, file, "next=\"");
3019 if (cLOOPo->op_nextop)
3020 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3022 PerlIO_printf(file, "DONE\"");
3023 S_xmldump_attr(aTHX_ level, file, "last=\"");
3024 if (cLOOPo->op_lastop)
3025 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3027 PerlIO_printf(file, "DONE\"");
3035 S_xmldump_attr(aTHX_ level, file, "other=\"");
3036 if (cLOGOPo->op_other)
3037 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3039 PerlIO_printf(file, "DONE\"");
3047 if (o->op_private & OPpREFCOUNTED)
3048 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3054 if (PL_madskills && o->op_madprop) {
3055 char prevkey = '\0';
3056 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3057 const MADPROP* mp = o->op_madprop;
3061 PerlIO_printf(file, ">\n");
3063 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3066 char tmp = mp->mad_key;
3067 sv_setpvs(tmpsv,"\"");
3069 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3070 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3071 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3074 sv_catpv(tmpsv, "\"");
3075 switch (mp->mad_type) {
3077 sv_catpv(tmpsv, "NULL");
3078 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3081 sv_catpv(tmpsv, " val=\"");
3082 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3083 sv_catpv(tmpsv, "\"");
3084 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3087 sv_catpv(tmpsv, " val=\"");
3088 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3089 sv_catpv(tmpsv, "\"");
3090 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3093 if ((OP*)mp->mad_val) {
3094 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3095 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3096 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3100 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3106 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3108 SvREFCNT_dec(tmpsv);
3111 switch (o->op_type) {
3118 PerlIO_printf(file, ">\n");
3120 do_pmop_xmldump(level, file, cPMOPo);
3126 if (o->op_flags & OPf_KIDS) {
3130 PerlIO_printf(file, ">\n");
3132 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3133 do_op_xmldump(level, file, kid);
3137 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3139 PerlIO_printf(file, " />\n");
3143 Perl_op_xmldump(pTHX_ const OP *o)
3145 PERL_ARGS_ASSERT_OP_XMLDUMP;
3147 do_op_xmldump(0, PL_xmlfp, o);
3153 * c-indentation-style: bsd
3155 * indent-tabs-mode: t
3158 * ex: set ts=8 sts=4 sw=4 noet: