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 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"},
794 {OPf_STACKED, ",STACKED"},
795 {OPf_SPECIAL, ",SPECIAL"}
798 const struct flag_to_name op_trans_names[] = {
799 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
800 {OPpTRANS_TO_UTF, ",TO_UTF"},
801 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
802 {OPpTRANS_SQUASH, ",SQUASH"},
803 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
804 {OPpTRANS_GROWS, ",GROWS"},
805 {OPpTRANS_DELETE, ",DELETE"}
808 const struct flag_to_name op_entersub_names[] = {
809 {OPpENTERSUB_DB, ",DB"},
810 {OPpENTERSUB_HASTARG, ",HASTARG"},
811 {OPpENTERSUB_NOMOD, ",NOMOD"},
812 {OPpENTERSUB_AMPER, ",AMPER"},
813 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
814 {OPpENTERSUB_INARGS, ",INARGS"}
817 const struct flag_to_name op_const_names[] = {
818 {OPpCONST_NOVER, ",NOVER"},
819 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
820 {OPpCONST_STRICT, ",STRICT"},
821 {OPpCONST_ENTERED, ",ENTERED"},
822 {OPpCONST_ARYBASE, ",ARYBASE"},
823 {OPpCONST_BARE, ",BARE"},
824 {OPpCONST_WARNING, ",WARNING"}
827 const struct flag_to_name op_sort_names[] = {
828 {OPpSORT_NUMERIC, ",NUMERIC"},
829 {OPpSORT_INTEGER, ",INTEGER"},
830 {OPpSORT_REVERSE, ",REVERSE"},
831 {OPpSORT_INPLACE, ",INPLACE"},
832 {OPpSORT_DESCEND, ",DESCEND"},
833 {OPpSORT_QSORT, ",QSORT"},
834 {OPpSORT_STABLE, ",STABLE"}
837 const struct flag_to_name op_open_names[] = {
838 {OPpOPEN_IN_RAW, ",IN_RAW"},
839 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
840 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
841 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
844 const struct flag_to_name op_exit_names[] = {
845 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
846 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
849 #define OP_PRIVATE_ONCE(op, flag, name) \
850 const struct flag_to_name CAT2(op, _names)[] = { \
854 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
855 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
856 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
857 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
858 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
859 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
860 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
861 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
862 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
863 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
864 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
865 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
867 struct op_private_by_op {
870 const struct flag_to_name *start;
873 const struct op_private_by_op op_private_names[] = {
874 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
875 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
876 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
877 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
878 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
879 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
880 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
881 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
882 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
883 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
884 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
885 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
886 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
887 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
888 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
889 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
890 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
891 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
892 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
893 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
894 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
898 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
899 const struct op_private_by_op *start = op_private_names;
900 const struct op_private_by_op *const end
901 = op_private_names + C_ARRAY_LENGTH(op_private_names);
903 /* This is a linear search, but no worse than the code that it replaced.
904 It's debugging code - size is more important than speed. */
906 if (optype == start->op_type) {
907 S_append_flags(aTHX_ tmpsv, op_private, start->start,
908 start->start + start->len);
911 } while (++start < end);
916 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
920 const OPCODE optype = o->op_type;
922 PERL_ARGS_ASSERT_DO_OP_DUMP;
925 Perl_dump_indent(aTHX_ level, file, "{\n");
927 seq = sequence_num(o);
929 PerlIO_printf(file, "%-4"UVuf, seq);
931 PerlIO_printf(file, " ");
933 "%*sTYPE = %s ===> ",
934 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
936 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
937 sequence_num(o->op_next));
939 PerlIO_printf(file, "DONE\n");
941 if (optype == OP_NULL) {
942 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
943 if (o->op_targ == OP_NEXTSTATE) {
945 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
947 if (CopSTASHPV(cCOPo))
948 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
951 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
956 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
959 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
961 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
962 SV * const tmpsv = newSVpvs("");
963 switch (o->op_flags & OPf_WANT) {
965 sv_catpv(tmpsv, ",VOID");
967 case OPf_WANT_SCALAR:
968 sv_catpv(tmpsv, ",SCALAR");
971 sv_catpv(tmpsv, ",LIST");
974 sv_catpv(tmpsv, ",UNKNOWN");
977 append_flags(tmpsv, o->op_flags, op_flags_names);
979 sv_catpv(tmpsv, ",LATEFREE");
981 sv_catpv(tmpsv, ",LATEFREED");
983 sv_catpv(tmpsv, ",ATTACHED");
984 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
988 SV * const tmpsv = newSVpvs("");
989 if (PL_opargs[optype] & OA_TARGLEX) {
990 if (o->op_private & OPpTARGET_MY)
991 sv_catpv(tmpsv, ",TARGET_MY");
993 else if (optype == OP_ENTERSUB ||
994 optype == OP_RV2SV ||
996 optype == OP_RV2AV ||
997 optype == OP_RV2HV ||
998 optype == OP_RV2GV ||
999 optype == OP_AELEM ||
1000 optype == OP_HELEM )
1002 if (optype == OP_ENTERSUB) {
1003 append_flags(tmpsv, o->op_private, op_entersub_names);
1006 switch (o->op_private & OPpDEREF) {
1008 sv_catpv(tmpsv, ",SV");
1011 sv_catpv(tmpsv, ",AV");
1014 sv_catpv(tmpsv, ",HV");
1017 if (o->op_private & OPpMAYBE_LVSUB)
1018 sv_catpv(tmpsv, ",MAYBE_LVSUB");
1021 if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
1022 && (o->op_private & OPpDEREFed))
1023 sv_catpv(tmpsv, ",DEREFed");
1025 if (optype == OP_AELEM || optype == OP_HELEM) {
1026 if (o->op_private & OPpLVAL_DEFER)
1027 sv_catpv(tmpsv, ",LVAL_DEFER");
1030 if (o->op_private & HINT_STRICT_REFS)
1031 sv_catpv(tmpsv, ",STRICT_REFS");
1032 if (o->op_private & OPpOUR_INTRO)
1033 sv_catpv(tmpsv, ",OUR_INTRO");
1036 else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
1038 else if (PL_check[optype] != Perl_ck_ftst) {
1039 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1040 sv_catpv(tmpsv, ",FT_ACCESS");
1041 if (o->op_private & OPpFT_STACKED)
1042 sv_catpv(tmpsv, ",FT_STACKED");
1044 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1045 sv_catpv(tmpsv, ",INTRO");
1047 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1048 SvREFCNT_dec(tmpsv);
1052 if (PL_madskills && o->op_madprop) {
1053 SV * const tmpsv = newSVpvs("");
1054 MADPROP* mp = o->op_madprop;
1055 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1058 const char tmp = mp->mad_key;
1059 sv_setpvs(tmpsv,"'");
1061 sv_catpvn(tmpsv, &tmp, 1);
1062 sv_catpv(tmpsv, "'=");
1063 switch (mp->mad_type) {
1065 sv_catpv(tmpsv, "NULL");
1066 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1069 sv_catpv(tmpsv, "<");
1070 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1071 sv_catpv(tmpsv, ">");
1072 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1075 if ((OP*)mp->mad_val) {
1076 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1077 do_op_dump(level, file, (OP*)mp->mad_val);
1081 sv_catpv(tmpsv, "(UNK)");
1082 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1088 Perl_dump_indent(aTHX_ level, file, "}\n");
1090 SvREFCNT_dec(tmpsv);
1099 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1101 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1102 if (cSVOPo->op_sv) {
1103 SV * const tmpsv = newSV(0);
1107 /* FIXME - is this making unwarranted assumptions about the
1108 UTF-8 cleanliness of the dump file handle? */
1111 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1112 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1113 SvPV_nolen_const(tmpsv));
1117 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1123 case OP_METHOD_NAMED:
1124 #ifndef USE_ITHREADS
1125 /* with ITHREADS, consts are stored in the pad, and the right pad
1126 * may not be active here, so skip */
1127 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1133 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1134 (UV)CopLINE(cCOPo));
1135 if (CopSTASHPV(cCOPo))
1136 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1138 if (CopLABEL(cCOPo))
1139 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1143 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1144 if (cLOOPo->op_redoop)
1145 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1147 PerlIO_printf(file, "DONE\n");
1148 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1149 if (cLOOPo->op_nextop)
1150 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1152 PerlIO_printf(file, "DONE\n");
1153 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1154 if (cLOOPo->op_lastop)
1155 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1157 PerlIO_printf(file, "DONE\n");
1165 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1166 if (cLOGOPo->op_other)
1167 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1169 PerlIO_printf(file, "DONE\n");
1175 do_pmop_dump(level, file, cPMOPo);
1183 if (o->op_private & OPpREFCOUNTED)
1184 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1189 if (o->op_flags & OPf_KIDS) {
1191 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1192 do_op_dump(level, file, kid);
1194 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1198 Perl_op_dump(pTHX_ const OP *o)
1200 PERL_ARGS_ASSERT_OP_DUMP;
1201 do_op_dump(0, Perl_debug_log, o);
1205 Perl_gv_dump(pTHX_ GV *gv)
1209 PERL_ARGS_ASSERT_GV_DUMP;
1212 PerlIO_printf(Perl_debug_log, "{}\n");
1215 sv = sv_newmortal();
1216 PerlIO_printf(Perl_debug_log, "{\n");
1217 gv_fullname3(sv, gv, NULL);
1218 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1219 if (gv != GvEGV(gv)) {
1220 gv_efullname3(sv, GvEGV(gv), NULL);
1221 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1223 PerlIO_putc(Perl_debug_log, '\n');
1224 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1228 /* map magic types to the symbolic names
1229 * (with the PERL_MAGIC_ prefixed stripped)
1232 static const struct { const char type; const char *name; } magic_names[] = {
1233 { PERL_MAGIC_sv, "sv(\\0)" },
1234 { PERL_MAGIC_arylen, "arylen(#)" },
1235 { PERL_MAGIC_rhash, "rhash(%)" },
1236 { PERL_MAGIC_pos, "pos(.)" },
1237 { PERL_MAGIC_symtab, "symtab(:)" },
1238 { PERL_MAGIC_backref, "backref(<)" },
1239 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1240 { PERL_MAGIC_overload, "overload(A)" },
1241 { PERL_MAGIC_bm, "bm(B)" },
1242 { PERL_MAGIC_regdata, "regdata(D)" },
1243 { PERL_MAGIC_env, "env(E)" },
1244 { PERL_MAGIC_hints, "hints(H)" },
1245 { PERL_MAGIC_isa, "isa(I)" },
1246 { PERL_MAGIC_dbfile, "dbfile(L)" },
1247 { PERL_MAGIC_shared, "shared(N)" },
1248 { PERL_MAGIC_tied, "tied(P)" },
1249 { PERL_MAGIC_sig, "sig(S)" },
1250 { PERL_MAGIC_uvar, "uvar(U)" },
1251 { PERL_MAGIC_checkcall, "checkcall(])" },
1252 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1253 { PERL_MAGIC_overload_table, "overload_table(c)" },
1254 { PERL_MAGIC_regdatum, "regdatum(d)" },
1255 { PERL_MAGIC_envelem, "envelem(e)" },
1256 { PERL_MAGIC_fm, "fm(f)" },
1257 { PERL_MAGIC_regex_global, "regex_global(g)" },
1258 { PERL_MAGIC_hintselem, "hintselem(h)" },
1259 { PERL_MAGIC_isaelem, "isaelem(i)" },
1260 { PERL_MAGIC_nkeys, "nkeys(k)" },
1261 { PERL_MAGIC_dbline, "dbline(l)" },
1262 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1263 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1264 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1265 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1266 { PERL_MAGIC_qr, "qr(r)" },
1267 { PERL_MAGIC_sigelem, "sigelem(s)" },
1268 { PERL_MAGIC_taint, "taint(t)" },
1269 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1270 { PERL_MAGIC_vec, "vec(v)" },
1271 { PERL_MAGIC_vstring, "vstring(V)" },
1272 { PERL_MAGIC_utf8, "utf8(w)" },
1273 { PERL_MAGIC_substr, "substr(x)" },
1274 { PERL_MAGIC_defelem, "defelem(y)" },
1275 { PERL_MAGIC_ext, "ext(~)" },
1276 /* this null string terminates the list */
1281 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1283 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1285 for (; mg; mg = mg->mg_moremagic) {
1286 Perl_dump_indent(aTHX_ level, file,
1287 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1288 if (mg->mg_virtual) {
1289 const MGVTBL * const v = mg->mg_virtual;
1291 if (v == &PL_vtbl_sv) s = "sv";
1292 else if (v == &PL_vtbl_env) s = "env";
1293 else if (v == &PL_vtbl_envelem) s = "envelem";
1294 else if (v == &PL_vtbl_sig) s = "sig";
1295 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1296 else if (v == &PL_vtbl_pack) s = "pack";
1297 else if (v == &PL_vtbl_packelem) s = "packelem";
1298 else if (v == &PL_vtbl_dbline) s = "dbline";
1299 else if (v == &PL_vtbl_isa) s = "isa";
1300 else if (v == &PL_vtbl_arylen) s = "arylen";
1301 else if (v == &PL_vtbl_mglob) s = "mglob";
1302 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1303 else if (v == &PL_vtbl_taint) s = "taint";
1304 else if (v == &PL_vtbl_substr) s = "substr";
1305 else if (v == &PL_vtbl_vec) s = "vec";
1306 else if (v == &PL_vtbl_pos) s = "pos";
1307 else if (v == &PL_vtbl_bm) s = "bm";
1308 else if (v == &PL_vtbl_fm) s = "fm";
1309 else if (v == &PL_vtbl_uvar) s = "uvar";
1310 else if (v == &PL_vtbl_defelem) s = "defelem";
1311 #ifdef USE_LOCALE_COLLATE
1312 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1314 else if (v == &PL_vtbl_amagic) s = "amagic";
1315 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1316 else if (v == &PL_vtbl_backref) s = "backref";
1317 else if (v == &PL_vtbl_utf8) s = "utf8";
1318 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1319 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1320 else if (v == &PL_vtbl_hints) s = "hints";
1323 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1325 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1328 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1331 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1335 const char *name = NULL;
1336 for (n = 0; magic_names[n].name; n++) {
1337 if (mg->mg_type == magic_names[n].type) {
1338 name = magic_names[n].name;
1343 Perl_dump_indent(aTHX_ level, file,
1344 " MG_TYPE = PERL_MAGIC_%s\n", name);
1346 Perl_dump_indent(aTHX_ level, file,
1347 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1351 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1352 if (mg->mg_type == PERL_MAGIC_envelem &&
1353 mg->mg_flags & MGf_TAINTEDDIR)
1354 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1355 if (mg->mg_type == PERL_MAGIC_regex_global &&
1356 mg->mg_flags & MGf_MINMATCH)
1357 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1358 if (mg->mg_flags & MGf_REFCOUNTED)
1359 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1360 if (mg->mg_flags & MGf_GSKIP)
1361 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1362 if (mg->mg_flags & MGf_COPY)
1363 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1364 if (mg->mg_flags & MGf_DUP)
1365 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1366 if (mg->mg_flags & MGf_LOCAL)
1367 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
1370 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1371 PTR2UV(mg->mg_obj));
1372 if (mg->mg_type == PERL_MAGIC_qr) {
1373 REGEXP* const re = (REGEXP *)mg->mg_obj;
1374 SV * const dsv = sv_newmortal();
1375 const char * const s
1376 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1378 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1379 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1381 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1382 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1385 if (mg->mg_flags & MGf_REFCOUNTED)
1386 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1389 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1391 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1392 if (mg->mg_len >= 0) {
1393 if (mg->mg_type != PERL_MAGIC_utf8) {
1394 SV * const sv = newSVpvs("");
1395 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1399 else if (mg->mg_len == HEf_SVKEY) {
1400 PerlIO_puts(file, " => HEf_SVKEY\n");
1401 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1402 maxnest, dumpops, pvlim); /* MG is already +1 */
1405 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1410 " does not know how to handle this MG_LEN"
1412 PerlIO_putc(file, '\n');
1414 if (mg->mg_type == PERL_MAGIC_utf8) {
1415 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1418 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1419 Perl_dump_indent(aTHX_ level, file,
1420 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1423 (UV)cache[i * 2 + 1]);
1430 Perl_magic_dump(pTHX_ const MAGIC *mg)
1432 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1436 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1440 PERL_ARGS_ASSERT_DO_HV_DUMP;
1442 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1443 if (sv && (hvname = HvNAME_get(sv)))
1445 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1446 name which quite legally could contain insane things like tabs, newlines, nulls or
1447 other scary crap - this should produce sane results - except maybe for unicode package
1448 names - but we will wait for someone to file a bug on that - demerphq */
1449 SV * const tmpsv = newSVpvs("");
1450 PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1453 PerlIO_putc(file, '\n');
1457 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1459 PERL_ARGS_ASSERT_DO_GV_DUMP;
1461 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1462 if (sv && GvNAME(sv))
1463 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1465 PerlIO_putc(file, '\n');
1469 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1471 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1473 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1474 if (sv && GvNAME(sv)) {
1476 PerlIO_printf(file, "\t\"");
1477 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1478 PerlIO_printf(file, "%s\" :: \"", hvname);
1479 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1482 PerlIO_putc(file, '\n');
1485 const struct flag_to_name first_sv_flags_names[] = {
1486 {SVs_TEMP, "TEMP,"},
1487 {SVs_OBJECT, "OBJECT,"},
1496 const struct flag_to_name second_sv_flags_names[] = {
1498 {SVf_FAKE, "FAKE,"},
1499 {SVf_READONLY, "READONLY,"},
1500 {SVf_BREAK, "BREAK,"},
1501 {SVf_AMAGIC, "OVERLOAD,"},
1507 const struct flag_to_name cv_flags_names[] = {
1508 {CVf_ANON, "ANON,"},
1509 {CVf_UNIQUE, "UNIQUE,"},
1510 {CVf_CLONE, "CLONE,"},
1511 {CVf_CLONED, "CLONED,"},
1512 {CVf_CONST, "CONST,"},
1513 {CVf_NODEBUG, "NODEBUG,"},
1514 {CVf_LVALUE, "LVALUE,"},
1515 {CVf_METHOD, "METHOD,"},
1516 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1517 {CVf_CVGV_RC, "CVGV_RC,"},
1518 {CVf_ISXSUB, "ISXSUB,"}
1521 const struct flag_to_name hv_flags_names[] = {
1522 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1523 {SVphv_LAZYDEL, "LAZYDEL,"},
1524 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1525 {SVphv_REHASH, "REHASH,"},
1526 {SVphv_CLONEABLE, "CLONEABLE,"}
1529 const struct flag_to_name gp_flags_names[] = {
1530 {GVf_INTRO, "INTRO,"},
1531 {GVf_MULTI, "MULTI,"},
1532 {GVf_ASSUMECV, "ASSUMECV,"},
1533 {GVf_IN_PAD, "IN_PAD,"}
1536 const struct flag_to_name gp_flags_imported_names[] = {
1537 {GVf_IMPORTED_SV, " SV"},
1538 {GVf_IMPORTED_AV, " AV"},
1539 {GVf_IMPORTED_HV, " HV"},
1540 {GVf_IMPORTED_CV, " CV"},
1544 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1552 PERL_ARGS_ASSERT_DO_SV_DUMP;
1555 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1559 flags = SvFLAGS(sv);
1562 d = Perl_newSVpvf(aTHX_
1563 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1564 PTR2UV(SvANY(sv)), PTR2UV(sv),
1565 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1566 (int)(PL_dumpindent*level), "");
1568 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1569 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1571 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1572 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1573 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1575 append_flags(d, flags, first_sv_flags_names);
1576 if (flags & SVf_ROK) {
1577 sv_catpv(d, "ROK,");
1578 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1580 append_flags(d, flags, second_sv_flags_names);
1581 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1582 if (SvPCS_IMPORTED(sv))
1583 sv_catpv(d, "PCS_IMPORTED,");
1585 sv_catpv(d, "SCREAM,");
1591 append_flags(d, CvFLAGS(sv), cv_flags_names);
1592 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1595 append_flags(d, flags, hv_flags_names);
1599 if (isGV_with_GP(sv)) {
1600 append_flags(d, GvFLAGS(sv), gp_flags_names);
1602 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1603 sv_catpv(d, "IMPORT");
1604 if (GvIMPORTED(sv) == GVf_IMPORTED)
1605 sv_catpv(d, "ALL,");
1608 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1612 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1613 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1617 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1618 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1621 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1622 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1625 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1630 /* SVphv_SHAREKEYS is also 0x20000000 */
1631 if ((type != SVt_PVHV) && SvUTF8(sv))
1632 sv_catpv(d, "UTF8");
1634 if (*(SvEND(d) - 1) == ',') {
1635 SvCUR_set(d, SvCUR(d) - 1);
1636 SvPVX(d)[SvCUR(d)] = '\0';
1641 #ifdef DEBUG_LEAKING_SCALARS
1642 Perl_dump_indent(aTHX_ level, file,
1643 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1644 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1646 sv->sv_debug_inpad ? "for" : "by",
1647 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1648 PTR2UV(sv->sv_debug_parent),
1652 Perl_dump_indent(aTHX_ level, file, "SV = ");
1653 if (type < SVt_LAST) {
1654 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1656 if (type == SVt_NULL) {
1661 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1665 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1666 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM
1667 && type != SVt_PVIO && type != SVt_REGEXP)
1668 || (type == SVt_IV && !SvROK(sv))) {
1670 #ifdef PERL_OLD_COPY_ON_WRITE
1674 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1676 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1677 #ifdef PERL_OLD_COPY_ON_WRITE
1678 if (SvIsCOW_shared_hash(sv))
1679 PerlIO_printf(file, " (HASH)");
1680 else if (SvIsCOW_normal(sv))
1681 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1683 PerlIO_putc(file, '\n');
1685 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1686 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1687 (UV) COP_SEQ_RANGE_LOW(sv));
1688 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1689 (UV) COP_SEQ_RANGE_HIGH(sv));
1690 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1691 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1692 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1693 || type == SVt_NV) {
1694 STORE_NUMERIC_LOCAL_SET_STANDARD();
1695 /* %Vg doesn't work? --jhi */
1696 #ifdef USE_LONG_DOUBLE
1697 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1699 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1701 RESTORE_NUMERIC_LOCAL();
1704 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1706 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1708 if (type < SVt_PV) {
1712 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1713 if (SvPVX_const(sv)) {
1716 SvOOK_offset(sv, delta);
1717 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1722 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1724 PerlIO_printf(file, "( %s . ) ",
1725 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1728 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1729 if (SvUTF8(sv)) /* the 6? \x{....} */
1730 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1731 PerlIO_printf(file, "\n");
1732 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1733 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1736 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1738 if (type == SVt_REGEXP) {
1740 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1741 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1744 if (type >= SVt_PVMG) {
1745 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1746 HV * const ost = SvOURSTASH(sv);
1748 do_hv_dump(level, file, " OURSTASH", ost);
1751 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1754 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1758 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1759 if (AvARRAY(sv) != AvALLOC(sv)) {
1760 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1761 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1764 PerlIO_putc(file, '\n');
1765 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1766 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1767 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1769 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1770 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1771 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1772 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1773 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1775 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1776 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1778 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1780 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1785 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1786 if (HvARRAY(sv) && HvKEYS(sv)) {
1787 /* Show distribution of HEs in the ARRAY */
1789 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1792 U32 pow2 = 2, keys = HvKEYS(sv);
1793 NV theoret, sum = 0;
1795 PerlIO_printf(file, " (");
1796 Zero(freq, FREQ_MAX + 1, int);
1797 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1800 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1802 if (count > FREQ_MAX)
1808 for (i = 0; i <= max; i++) {
1810 PerlIO_printf(file, "%d%s:%d", i,
1811 (i == FREQ_MAX) ? "+" : "",
1814 PerlIO_printf(file, ", ");
1817 PerlIO_putc(file, ')');
1818 /* The "quality" of a hash is defined as the total number of
1819 comparisons needed to access every element once, relative
1820 to the expected number needed for a random hash.
1822 The total number of comparisons is equal to the sum of
1823 the squares of the number of entries in each bucket.
1824 For a random hash of n keys into k buckets, the expected
1829 for (i = max; i > 0; i--) { /* Precision: count down. */
1830 sum += freq[i] * i * i;
1832 while ((keys = keys >> 1))
1834 theoret = HvKEYS(sv);
1835 theoret += theoret * (theoret-1)/pow2;
1836 PerlIO_putc(file, '\n');
1837 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1839 PerlIO_putc(file, '\n');
1840 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1841 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1842 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1843 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1844 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1846 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1847 if (mg && mg->mg_obj) {
1848 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1852 const char * const hvname = HvNAME_get(sv);
1854 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1858 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1859 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1860 if (HvAUX(sv)->xhv_name_count)
1861 Perl_dump_indent(aTHX_
1862 level, file, " NAMECOUNT = %"IVdf"\n",
1863 (IV)HvAUX(sv)->xhv_name_count
1865 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1866 const I32 count = HvAUX(sv)->xhv_name_count;
1868 SV * const names = newSVpvs_flags("", SVs_TEMP);
1869 /* The starting point is the first element if count is
1870 positive and the second element if count is negative. */
1871 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1872 + (count < 0 ? 1 : 0);
1873 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1874 + (count < 0 ? -count : count);
1875 while (hekp < endp) {
1877 sv_catpvs(names, ", \"");
1878 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1879 sv_catpvs(names, "\"");
1881 /* This should never happen. */
1882 sv_catpvs(names, ", (null)");
1886 Perl_dump_indent(aTHX_
1887 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1891 Perl_dump_indent(aTHX_
1892 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1896 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1898 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1902 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1903 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1904 (int)meta->mro_which->length,
1905 meta->mro_which->name,
1906 PTR2UV(meta->mro_which));
1907 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1908 (UV)meta->cache_gen);
1909 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1911 if (meta->mro_linear_all) {
1912 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1913 PTR2UV(meta->mro_linear_all));
1914 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1917 if (meta->mro_linear_current) {
1918 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1919 PTR2UV(meta->mro_linear_current));
1920 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1923 if (meta->mro_nextmethod) {
1924 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1925 PTR2UV(meta->mro_nextmethod));
1926 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1930 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1932 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1937 if (nest < maxnest) {
1938 if (HvEITER_get(sv)) /* preserve iterator */
1939 Perl_dump_indent(aTHX_ level, file,
1940 " (*** Active iterator; skipping element dump ***)\n");
1943 HV * const hv = MUTABLE_HV(sv);
1944 int count = maxnest - nest;
1947 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1950 const U32 hash = HeHASH(he);
1951 SV * const keysv = hv_iterkeysv(he);
1952 const char * const keypv = SvPV_const(keysv, len);
1953 SV * const elt = hv_iterval(hv, he);
1955 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1957 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1959 PerlIO_printf(file, "[REHASH] ");
1960 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1961 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1963 hv_iterinit(hv); /* Return to status quo */
1970 const char *const proto = SvPV_const(sv, len);
1971 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1976 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1977 if (!CvISXSUB(sv)) {
1979 Perl_dump_indent(aTHX_ level, file,
1980 " START = 0x%"UVxf" ===> %"IVdf"\n",
1981 PTR2UV(CvSTART(sv)),
1982 (IV)sequence_num(CvSTART(sv)));
1984 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1985 PTR2UV(CvROOT(sv)));
1986 if (CvROOT(sv) && dumpops) {
1987 do_op_dump(level+1, file, CvROOT(sv));
1990 SV * const constant = cv_const_sv((const CV *)sv);
1992 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1995 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1997 PTR2UV(CvXSUBANY(sv).any_ptr));
1998 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2001 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
2002 (IV)CvXSUBANY(sv).any_i32);
2005 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
2006 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
2007 if (type == SVt_PVCV)
2008 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2009 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2010 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2011 if (type == SVt_PVFM)
2012 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
2013 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2014 if (nest < maxnest) {
2015 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2018 const CV * const outside = CvOUTSIDE(sv);
2019 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
2022 : CvANON(outside) ? "ANON"
2023 : (outside == PL_main_cv) ? "MAIN"
2024 : CvUNIQUE(outside) ? "UNIQUE"
2025 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2027 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2028 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2032 if (type == SVt_PVLV) {
2033 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2034 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2035 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2036 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2037 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2038 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2042 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
2043 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
2044 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
2045 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
2047 if (!isGV_with_GP(sv))
2049 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
2050 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2051 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
2052 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2055 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2056 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2057 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2058 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2059 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2060 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2061 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2062 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2063 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2064 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2065 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2066 do_gv_dump (level, file, " EGV", GvEGV(sv));
2069 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2070 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2071 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2072 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2073 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2074 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2075 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2077 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2078 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2079 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2081 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2082 PTR2UV(IoTOP_GV(sv)));
2083 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2084 maxnest, dumpops, pvlim);
2086 /* Source filters hide things that are not GVs in these three, so let's
2087 be careful out there. */
2089 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2090 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2091 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2093 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2094 PTR2UV(IoFMT_GV(sv)));
2095 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2096 maxnest, dumpops, pvlim);
2098 if (IoBOTTOM_NAME(sv))
2099 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2100 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2101 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2103 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2104 PTR2UV(IoBOTTOM_GV(sv)));
2105 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2106 maxnest, dumpops, pvlim);
2108 if (isPRINT(IoTYPE(sv)))
2109 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2111 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2112 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2119 Perl_sv_dump(pTHX_ SV *sv)
2123 PERL_ARGS_ASSERT_SV_DUMP;
2126 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2128 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2132 Perl_runops_debug(pTHX)
2136 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2140 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2143 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2144 PerlIO_printf(Perl_debug_log,
2145 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2146 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2147 PTR2UV(*PL_watchaddr));
2148 if (DEBUG_s_TEST_) {
2149 if (DEBUG_v_TEST_) {
2150 PerlIO_printf(Perl_debug_log, "\n");
2158 if (DEBUG_t_TEST_) debop(PL_op);
2159 if (DEBUG_P_TEST_) debprof(PL_op);
2161 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2162 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2169 Perl_debop(pTHX_ const OP *o)
2173 PERL_ARGS_ASSERT_DEBOP;
2175 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2178 Perl_deb(aTHX_ "%s", OP_NAME(o));
2179 switch (o->op_type) {
2182 /* With ITHREADS, consts are stored in the pad, and the right pad
2183 * may not be active here, so check.
2184 * Looks like only during compiling the pads are illegal.
2187 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2189 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2194 SV * const sv = newSV(0);
2196 /* FIXME - is this making unwarranted assumptions about the
2197 UTF-8 cleanliness of the dump file handle? */
2200 gv_fullname3(sv, cGVOPo_gv, NULL);
2201 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2205 PerlIO_printf(Perl_debug_log, "(NULL)");
2211 /* print the lexical's name */
2212 CV * const cv = deb_curcv(cxstack_ix);
2215 AV * const padlist = CvPADLIST(cv);
2216 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2217 sv = *av_fetch(comppad, o->op_targ, FALSE);
2221 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2223 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2229 PerlIO_printf(Perl_debug_log, "\n");
2234 S_deb_curcv(pTHX_ const I32 ix)
2237 const PERL_CONTEXT * const cx = &cxstack[ix];
2238 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2239 return cx->blk_sub.cv;
2240 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2242 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2247 return deb_curcv(ix - 1);
2251 Perl_watch(pTHX_ char **addr)
2255 PERL_ARGS_ASSERT_WATCH;
2257 PL_watchaddr = addr;
2259 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2260 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2264 S_debprof(pTHX_ const OP *o)
2268 PERL_ARGS_ASSERT_DEBPROF;
2270 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2272 if (!PL_profiledata)
2273 Newxz(PL_profiledata, MAXO, U32);
2274 ++PL_profiledata[o->op_type];
2278 Perl_debprofdump(pTHX)
2282 if (!PL_profiledata)
2284 for (i = 0; i < MAXO; i++) {
2285 if (PL_profiledata[i])
2286 PerlIO_printf(Perl_debug_log,
2287 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2294 * XML variants of most of the above routines
2298 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2302 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2304 PerlIO_printf(file, "\n ");
2305 va_start(args, pat);
2306 xmldump_vindent(level, file, pat, &args);
2312 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2315 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2316 va_start(args, pat);
2317 xmldump_vindent(level, file, pat, &args);
2322 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2324 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2326 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2327 PerlIO_vprintf(file, pat, *args);
2331 Perl_xmldump_all(pTHX)
2333 xmldump_all_perl(FALSE);
2337 Perl_xmldump_all_perl(pTHX_ bool justperl)
2339 PerlIO_setlinebuf(PL_xmlfp);
2341 op_xmldump(PL_main_root);
2342 xmldump_packsubs_perl(PL_defstash, justperl);
2343 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2344 PerlIO_close(PL_xmlfp);
2349 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2351 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2352 xmldump_packsubs_perl(stash, FALSE);
2356 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2361 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2363 if (!HvARRAY(stash))
2365 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2366 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2367 GV *gv = MUTABLE_GV(HeVAL(entry));
2369 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2372 xmldump_sub_perl(gv, justperl);
2375 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2376 && (hv = GvHV(gv)) && hv != PL_defstash)
2377 xmldump_packsubs_perl(hv, justperl); /* nested package */
2383 Perl_xmldump_sub(pTHX_ const GV *gv)
2385 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2386 xmldump_sub_perl(gv, FALSE);
2390 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2394 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2396 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2399 sv = sv_newmortal();
2400 gv_fullname3(sv, gv, NULL);
2401 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2402 if (CvXSUB(GvCV(gv)))
2403 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2404 PTR2UV(CvXSUB(GvCV(gv))),
2405 (int)CvXSUBANY(GvCV(gv)).any_i32);
2406 else if (CvROOT(GvCV(gv)))
2407 op_xmldump(CvROOT(GvCV(gv)));
2409 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2413 Perl_xmldump_form(pTHX_ const GV *gv)
2415 SV * const sv = sv_newmortal();
2417 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2419 gv_fullname3(sv, gv, NULL);
2420 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2421 if (CvROOT(GvFORM(gv)))
2422 op_xmldump(CvROOT(GvFORM(gv)));
2424 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2428 Perl_xmldump_eval(pTHX)
2430 op_xmldump(PL_eval_root);
2434 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2436 PERL_ARGS_ASSERT_SV_CATXMLSV;
2437 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2441 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2443 PERL_ARGS_ASSERT_SV_CATXMLPV;
2444 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2448 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2451 const char * const e = pv + len;
2452 const char * const start = pv;
2456 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2459 dsvcur = SvCUR(dsv); /* in case we have to restart */
2464 c = utf8_to_uvchr((U8*)pv, &cl);
2466 SvCUR(dsv) = dsvcur;
2531 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2534 sv_catpvs(dsv, "<");
2537 sv_catpvs(dsv, ">");
2540 sv_catpvs(dsv, "&");
2543 sv_catpvs(dsv, """);
2547 if (c < 32 || c > 127) {
2548 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2551 const char string = (char) c;
2552 sv_catpvn(dsv, &string, 1);
2556 if ((c >= 0xD800 && c <= 0xDB7F) ||
2557 (c >= 0xDC00 && c <= 0xDFFF) ||
2558 (c >= 0xFFF0 && c <= 0xFFFF) ||
2560 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2562 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2575 Perl_sv_xmlpeek(pTHX_ SV *sv)
2577 SV * const t = sv_newmortal();
2581 PERL_ARGS_ASSERT_SV_XMLPEEK;
2587 sv_catpv(t, "VOID=\"\"");
2590 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2591 sv_catpv(t, "WILD=\"\"");
2594 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2595 if (sv == &PL_sv_undef) {
2596 sv_catpv(t, "SV_UNDEF=\"1\"");
2597 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2598 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2602 else if (sv == &PL_sv_no) {
2603 sv_catpv(t, "SV_NO=\"1\"");
2604 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2605 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2606 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2607 SVp_POK|SVp_NOK)) &&
2612 else if (sv == &PL_sv_yes) {
2613 sv_catpv(t, "SV_YES=\"1\"");
2614 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2615 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2616 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2617 SVp_POK|SVp_NOK)) &&
2619 SvPVX(sv) && *SvPVX(sv) == '1' &&
2624 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2625 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2626 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2630 sv_catpv(t, " XXX=\"\" ");
2632 else if (SvREFCNT(sv) == 0) {
2633 sv_catpv(t, " refcnt=\"0\"");
2636 else if (DEBUG_R_TEST_) {
2639 /* is this SV on the tmps stack? */
2640 for (ix=PL_tmps_ix; ix>=0; ix--) {
2641 if (PL_tmps_stack[ix] == sv) {
2646 if (SvREFCNT(sv) > 1)
2647 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2650 sv_catpv(t, " DRT=\"<T>\"");
2654 sv_catpv(t, " ROK=\"\"");
2656 switch (SvTYPE(sv)) {
2658 sv_catpv(t, " FREED=\"1\"");
2662 sv_catpv(t, " UNDEF=\"1\"");
2665 sv_catpv(t, " IV=\"");
2668 sv_catpv(t, " NV=\"");
2671 sv_catpv(t, " PV=\"");
2674 sv_catpv(t, " PVIV=\"");
2677 sv_catpv(t, " PVNV=\"");
2680 sv_catpv(t, " PVMG=\"");
2683 sv_catpv(t, " PVLV=\"");
2686 sv_catpv(t, " AV=\"");
2689 sv_catpv(t, " HV=\"");
2693 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2695 sv_catpv(t, " CV=\"()\"");
2698 sv_catpv(t, " GV=\"");
2701 sv_catpv(t, " BIND=\"");
2704 sv_catpv(t, " ORANGE=\"");
2707 sv_catpv(t, " FM=\"");
2710 sv_catpv(t, " IO=\"");
2719 else if (SvNOKp(sv)) {
2720 STORE_NUMERIC_LOCAL_SET_STANDARD();
2721 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2722 RESTORE_NUMERIC_LOCAL();
2724 else if (SvIOKp(sv)) {
2726 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2728 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2737 return SvPV(t, n_a);
2741 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2743 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2746 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2749 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2752 REGEXP *const r = PM_GETRE(pm);
2753 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2754 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2755 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2757 SvREFCNT_dec(tmpsv);
2758 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2759 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2762 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2763 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2764 SV * const tmpsv = pm_description(pm);
2765 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2766 SvREFCNT_dec(tmpsv);
2770 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2771 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2772 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2773 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2774 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2775 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2778 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2782 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2784 do_pmop_xmldump(0, PL_xmlfp, pm);
2788 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2793 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2798 seq = sequence_num(o);
2799 Perl_xmldump_indent(aTHX_ level, file,
2800 "<op_%s seq=\"%"UVuf" -> ",
2805 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2806 sequence_num(o->op_next));
2808 PerlIO_printf(file, "DONE\"");
2811 if (o->op_type == OP_NULL)
2813 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2814 if (o->op_targ == OP_NEXTSTATE)
2817 PerlIO_printf(file, " line=\"%"UVuf"\"",
2818 (UV)CopLINE(cCOPo));
2819 if (CopSTASHPV(cCOPo))
2820 PerlIO_printf(file, " package=\"%s\"",
2822 if (CopLABEL(cCOPo))
2823 PerlIO_printf(file, " label=\"%s\"",
2828 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2831 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2834 SV * const tmpsv = newSVpvs("");
2835 switch (o->op_flags & OPf_WANT) {
2837 sv_catpv(tmpsv, ",VOID");
2839 case OPf_WANT_SCALAR:
2840 sv_catpv(tmpsv, ",SCALAR");
2843 sv_catpv(tmpsv, ",LIST");
2846 sv_catpv(tmpsv, ",UNKNOWN");
2849 if (o->op_flags & OPf_KIDS)
2850 sv_catpv(tmpsv, ",KIDS");
2851 if (o->op_flags & OPf_PARENS)
2852 sv_catpv(tmpsv, ",PARENS");
2853 if (o->op_flags & OPf_STACKED)
2854 sv_catpv(tmpsv, ",STACKED");
2855 if (o->op_flags & OPf_REF)
2856 sv_catpv(tmpsv, ",REF");
2857 if (o->op_flags & OPf_MOD)
2858 sv_catpv(tmpsv, ",MOD");
2859 if (o->op_flags & OPf_SPECIAL)
2860 sv_catpv(tmpsv, ",SPECIAL");
2861 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2862 SvREFCNT_dec(tmpsv);
2864 if (o->op_private) {
2865 SV * const tmpsv = newSVpvs("");
2866 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2867 if (o->op_private & OPpTARGET_MY)
2868 sv_catpv(tmpsv, ",TARGET_MY");
2870 else if (o->op_type == OP_LEAVESUB ||
2871 o->op_type == OP_LEAVE ||
2872 o->op_type == OP_LEAVESUBLV ||
2873 o->op_type == OP_LEAVEWRITE) {
2874 if (o->op_private & OPpREFCOUNTED)
2875 sv_catpv(tmpsv, ",REFCOUNTED");
2877 else if (o->op_type == OP_AASSIGN) {
2878 if (o->op_private & OPpASSIGN_COMMON)
2879 sv_catpv(tmpsv, ",COMMON");
2881 else if (o->op_type == OP_SASSIGN) {
2882 if (o->op_private & OPpASSIGN_BACKWARDS)
2883 sv_catpv(tmpsv, ",BACKWARDS");
2885 else if (o->op_type == OP_TRANS) {
2886 if (o->op_private & OPpTRANS_SQUASH)
2887 sv_catpv(tmpsv, ",SQUASH");
2888 if (o->op_private & OPpTRANS_DELETE)
2889 sv_catpv(tmpsv, ",DELETE");
2890 if (o->op_private & OPpTRANS_COMPLEMENT)
2891 sv_catpv(tmpsv, ",COMPLEMENT");
2892 if (o->op_private & OPpTRANS_IDENTICAL)
2893 sv_catpv(tmpsv, ",IDENTICAL");
2894 if (o->op_private & OPpTRANS_GROWS)
2895 sv_catpv(tmpsv, ",GROWS");
2897 else if (o->op_type == OP_REPEAT) {
2898 if (o->op_private & OPpREPEAT_DOLIST)
2899 sv_catpv(tmpsv, ",DOLIST");
2901 else if (o->op_type == OP_ENTERSUB ||
2902 o->op_type == OP_RV2SV ||
2903 o->op_type == OP_GVSV ||
2904 o->op_type == OP_RV2AV ||
2905 o->op_type == OP_RV2HV ||
2906 o->op_type == OP_RV2GV ||
2907 o->op_type == OP_AELEM ||
2908 o->op_type == OP_HELEM )
2910 if (o->op_type == OP_ENTERSUB) {
2911 if (o->op_private & OPpENTERSUB_AMPER)
2912 sv_catpv(tmpsv, ",AMPER");
2913 if (o->op_private & OPpENTERSUB_DB)
2914 sv_catpv(tmpsv, ",DB");
2915 if (o->op_private & OPpENTERSUB_HASTARG)
2916 sv_catpv(tmpsv, ",HASTARG");
2917 if (o->op_private & OPpENTERSUB_NOPAREN)
2918 sv_catpv(tmpsv, ",NOPAREN");
2919 if (o->op_private & OPpENTERSUB_INARGS)
2920 sv_catpv(tmpsv, ",INARGS");
2921 if (o->op_private & OPpENTERSUB_NOMOD)
2922 sv_catpv(tmpsv, ",NOMOD");
2925 switch (o->op_private & OPpDEREF) {
2927 sv_catpv(tmpsv, ",SV");
2930 sv_catpv(tmpsv, ",AV");
2933 sv_catpv(tmpsv, ",HV");
2936 if (o->op_private & OPpMAYBE_LVSUB)
2937 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2939 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2940 if (o->op_private & OPpLVAL_DEFER)
2941 sv_catpv(tmpsv, ",LVAL_DEFER");
2944 if (o->op_private & HINT_STRICT_REFS)
2945 sv_catpv(tmpsv, ",STRICT_REFS");
2946 if (o->op_private & OPpOUR_INTRO)
2947 sv_catpv(tmpsv, ",OUR_INTRO");
2950 else if (o->op_type == OP_CONST) {
2951 if (o->op_private & OPpCONST_BARE)
2952 sv_catpv(tmpsv, ",BARE");
2953 if (o->op_private & OPpCONST_STRICT)
2954 sv_catpv(tmpsv, ",STRICT");
2955 if (o->op_private & OPpCONST_ARYBASE)
2956 sv_catpv(tmpsv, ",ARYBASE");
2957 if (o->op_private & OPpCONST_WARNING)
2958 sv_catpv(tmpsv, ",WARNING");
2959 if (o->op_private & OPpCONST_ENTERED)
2960 sv_catpv(tmpsv, ",ENTERED");
2962 else if (o->op_type == OP_FLIP) {
2963 if (o->op_private & OPpFLIP_LINENUM)
2964 sv_catpv(tmpsv, ",LINENUM");
2966 else if (o->op_type == OP_FLOP) {
2967 if (o->op_private & OPpFLIP_LINENUM)
2968 sv_catpv(tmpsv, ",LINENUM");
2970 else if (o->op_type == OP_RV2CV) {
2971 if (o->op_private & OPpLVAL_INTRO)
2972 sv_catpv(tmpsv, ",INTRO");
2974 else if (o->op_type == OP_GV) {
2975 if (o->op_private & OPpEARLY_CV)
2976 sv_catpv(tmpsv, ",EARLY_CV");
2978 else if (o->op_type == OP_LIST) {
2979 if (o->op_private & OPpLIST_GUESSED)
2980 sv_catpv(tmpsv, ",GUESSED");
2982 else if (o->op_type == OP_DELETE) {
2983 if (o->op_private & OPpSLICE)
2984 sv_catpv(tmpsv, ",SLICE");
2986 else if (o->op_type == OP_EXISTS) {
2987 if (o->op_private & OPpEXISTS_SUB)
2988 sv_catpv(tmpsv, ",EXISTS_SUB");
2990 else if (o->op_type == OP_SORT) {
2991 if (o->op_private & OPpSORT_NUMERIC)
2992 sv_catpv(tmpsv, ",NUMERIC");
2993 if (o->op_private & OPpSORT_INTEGER)
2994 sv_catpv(tmpsv, ",INTEGER");
2995 if (o->op_private & OPpSORT_REVERSE)
2996 sv_catpv(tmpsv, ",REVERSE");
2998 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2999 if (o->op_private & OPpOPEN_IN_RAW)
3000 sv_catpv(tmpsv, ",IN_RAW");
3001 if (o->op_private & OPpOPEN_IN_CRLF)
3002 sv_catpv(tmpsv, ",IN_CRLF");
3003 if (o->op_private & OPpOPEN_OUT_RAW)
3004 sv_catpv(tmpsv, ",OUT_RAW");
3005 if (o->op_private & OPpOPEN_OUT_CRLF)
3006 sv_catpv(tmpsv, ",OUT_CRLF");
3008 else if (o->op_type == OP_EXIT) {
3009 if (o->op_private & OPpEXIT_VMSISH)
3010 sv_catpv(tmpsv, ",EXIT_VMSISH");
3011 if (o->op_private & OPpHUSH_VMSISH)
3012 sv_catpv(tmpsv, ",HUSH_VMSISH");
3014 else if (o->op_type == OP_DIE) {
3015 if (o->op_private & OPpHUSH_VMSISH)
3016 sv_catpv(tmpsv, ",HUSH_VMSISH");
3018 else if (PL_check[o->op_type] != Perl_ck_ftst) {
3019 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
3020 sv_catpv(tmpsv, ",FT_ACCESS");
3021 if (o->op_private & OPpFT_STACKED)
3022 sv_catpv(tmpsv, ",FT_STACKED");
3024 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
3025 sv_catpv(tmpsv, ",INTRO");
3027 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
3028 SvREFCNT_dec(tmpsv);
3031 switch (o->op_type) {
3033 if (o->op_flags & OPf_SPECIAL) {
3039 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3041 if (cSVOPo->op_sv) {
3042 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3043 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3049 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3050 s = SvPV(tmpsv1,len);
3051 sv_catxmlpvn(tmpsv2, s, len, 1);
3052 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3056 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3061 case OP_METHOD_NAMED:
3062 #ifndef USE_ITHREADS
3063 /* with ITHREADS, consts are stored in the pad, and the right pad
3064 * may not be active here, so skip */
3065 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3071 PerlIO_printf(file, ">\n");
3073 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3078 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3079 (UV)CopLINE(cCOPo));
3080 if (CopSTASHPV(cCOPo))
3081 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3083 if (CopLABEL(cCOPo))
3084 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3088 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3089 if (cLOOPo->op_redoop)
3090 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3092 PerlIO_printf(file, "DONE\"");
3093 S_xmldump_attr(aTHX_ level, file, "next=\"");
3094 if (cLOOPo->op_nextop)
3095 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3097 PerlIO_printf(file, "DONE\"");
3098 S_xmldump_attr(aTHX_ level, file, "last=\"");
3099 if (cLOOPo->op_lastop)
3100 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3102 PerlIO_printf(file, "DONE\"");
3110 S_xmldump_attr(aTHX_ level, file, "other=\"");
3111 if (cLOGOPo->op_other)
3112 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3114 PerlIO_printf(file, "DONE\"");
3122 if (o->op_private & OPpREFCOUNTED)
3123 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3129 if (PL_madskills && o->op_madprop) {
3130 char prevkey = '\0';
3131 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3132 const MADPROP* mp = o->op_madprop;
3136 PerlIO_printf(file, ">\n");
3138 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3141 char tmp = mp->mad_key;
3142 sv_setpvs(tmpsv,"\"");
3144 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3145 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3146 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3149 sv_catpv(tmpsv, "\"");
3150 switch (mp->mad_type) {
3152 sv_catpv(tmpsv, "NULL");
3153 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3156 sv_catpv(tmpsv, " val=\"");
3157 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3158 sv_catpv(tmpsv, "\"");
3159 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3162 sv_catpv(tmpsv, " val=\"");
3163 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3164 sv_catpv(tmpsv, "\"");
3165 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3168 if ((OP*)mp->mad_val) {
3169 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3170 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3171 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3175 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3181 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3183 SvREFCNT_dec(tmpsv);
3186 switch (o->op_type) {
3193 PerlIO_printf(file, ">\n");
3195 do_pmop_xmldump(level, file, cPMOPo);
3201 if (o->op_flags & OPf_KIDS) {
3205 PerlIO_printf(file, ">\n");
3207 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3208 do_op_xmldump(level, file, kid);
3212 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3214 PerlIO_printf(file, " />\n");
3218 Perl_op_xmldump(pTHX_ const OP *o)
3220 PERL_ARGS_ASSERT_OP_XMLDUMP;
3222 do_op_xmldump(0, PL_xmlfp, o);
3228 * c-indentation-style: bsd
3230 * indent-tabs-mode: t
3233 * ex: set ts=8 sts=4 sw=4 noet: