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] != MEMBER_TO_FPTR(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_overload_elem, "overload_elem(a)" },
1252 { PERL_MAGIC_overload_table, "overload_table(c)" },
1253 { PERL_MAGIC_regdatum, "regdatum(d)" },
1254 { PERL_MAGIC_envelem, "envelem(e)" },
1255 { PERL_MAGIC_fm, "fm(f)" },
1256 { PERL_MAGIC_regex_global, "regex_global(g)" },
1257 { PERL_MAGIC_hintselem, "hintselem(h)" },
1258 { PERL_MAGIC_isaelem, "isaelem(i)" },
1259 { PERL_MAGIC_nkeys, "nkeys(k)" },
1260 { PERL_MAGIC_dbline, "dbline(l)" },
1261 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1262 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1263 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1264 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1265 { PERL_MAGIC_qr, "qr(r)" },
1266 { PERL_MAGIC_sigelem, "sigelem(s)" },
1267 { PERL_MAGIC_taint, "taint(t)" },
1268 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1269 { PERL_MAGIC_vec, "vec(v)" },
1270 { PERL_MAGIC_vstring, "vstring(V)" },
1271 { PERL_MAGIC_utf8, "utf8(w)" },
1272 { PERL_MAGIC_substr, "substr(x)" },
1273 { PERL_MAGIC_defelem, "defelem(y)" },
1274 { PERL_MAGIC_ext, "ext(~)" },
1275 /* this null string terminates the list */
1280 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1282 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1284 for (; mg; mg = mg->mg_moremagic) {
1285 Perl_dump_indent(aTHX_ level, file,
1286 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1287 if (mg->mg_virtual) {
1288 const MGVTBL * const v = mg->mg_virtual;
1290 if (v == &PL_vtbl_sv) s = "sv";
1291 else if (v == &PL_vtbl_env) s = "env";
1292 else if (v == &PL_vtbl_envelem) s = "envelem";
1293 else if (v == &PL_vtbl_sig) s = "sig";
1294 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1295 else if (v == &PL_vtbl_pack) s = "pack";
1296 else if (v == &PL_vtbl_packelem) s = "packelem";
1297 else if (v == &PL_vtbl_dbline) s = "dbline";
1298 else if (v == &PL_vtbl_isa) s = "isa";
1299 else if (v == &PL_vtbl_arylen) s = "arylen";
1300 else if (v == &PL_vtbl_mglob) s = "mglob";
1301 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1302 else if (v == &PL_vtbl_taint) s = "taint";
1303 else if (v == &PL_vtbl_substr) s = "substr";
1304 else if (v == &PL_vtbl_vec) s = "vec";
1305 else if (v == &PL_vtbl_pos) s = "pos";
1306 else if (v == &PL_vtbl_bm) s = "bm";
1307 else if (v == &PL_vtbl_fm) s = "fm";
1308 else if (v == &PL_vtbl_uvar) s = "uvar";
1309 else if (v == &PL_vtbl_defelem) s = "defelem";
1310 #ifdef USE_LOCALE_COLLATE
1311 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1313 else if (v == &PL_vtbl_amagic) s = "amagic";
1314 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1315 else if (v == &PL_vtbl_backref) s = "backref";
1316 else if (v == &PL_vtbl_utf8) s = "utf8";
1317 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1318 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1319 else if (v == &PL_vtbl_hints) s = "hints";
1322 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1324 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1327 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1330 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1334 const char *name = NULL;
1335 for (n = 0; magic_names[n].name; n++) {
1336 if (mg->mg_type == magic_names[n].type) {
1337 name = magic_names[n].name;
1342 Perl_dump_indent(aTHX_ level, file,
1343 " MG_TYPE = PERL_MAGIC_%s\n", name);
1345 Perl_dump_indent(aTHX_ level, file,
1346 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1350 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1351 if (mg->mg_type == PERL_MAGIC_envelem &&
1352 mg->mg_flags & MGf_TAINTEDDIR)
1353 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1354 if (mg->mg_flags & MGf_REFCOUNTED)
1355 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1356 if (mg->mg_flags & MGf_GSKIP)
1357 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1358 if (mg->mg_type == PERL_MAGIC_regex_global &&
1359 mg->mg_flags & MGf_MINMATCH)
1360 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1363 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1364 PTR2UV(mg->mg_obj));
1365 if (mg->mg_type == PERL_MAGIC_qr) {
1366 REGEXP* const re = (REGEXP *)mg->mg_obj;
1367 SV * const dsv = sv_newmortal();
1368 const char * const s
1369 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1371 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1372 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1374 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1375 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1378 if (mg->mg_flags & MGf_REFCOUNTED)
1379 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1382 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1384 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1385 if (mg->mg_len >= 0) {
1386 if (mg->mg_type != PERL_MAGIC_utf8) {
1387 SV * const sv = newSVpvs("");
1388 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1392 else if (mg->mg_len == HEf_SVKEY) {
1393 PerlIO_puts(file, " => HEf_SVKEY\n");
1394 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1395 maxnest, dumpops, pvlim); /* MG is already +1 */
1398 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1403 " does not know how to handle this MG_LEN"
1405 PerlIO_putc(file, '\n');
1407 if (mg->mg_type == PERL_MAGIC_utf8) {
1408 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1411 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1412 Perl_dump_indent(aTHX_ level, file,
1413 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1416 (UV)cache[i * 2 + 1]);
1423 Perl_magic_dump(pTHX_ const MAGIC *mg)
1425 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1429 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1433 PERL_ARGS_ASSERT_DO_HV_DUMP;
1435 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1436 if (sv && (hvname = HvNAME_get(sv)))
1437 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1439 PerlIO_putc(file, '\n');
1443 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1445 PERL_ARGS_ASSERT_DO_GV_DUMP;
1447 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1448 if (sv && GvNAME(sv))
1449 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1451 PerlIO_putc(file, '\n');
1455 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1457 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1459 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1460 if (sv && GvNAME(sv)) {
1462 PerlIO_printf(file, "\t\"");
1463 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1464 PerlIO_printf(file, "%s\" :: \"", hvname);
1465 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1468 PerlIO_putc(file, '\n');
1471 const struct flag_to_name first_sv_flags_names[] = {
1472 {SVs_TEMP, "TEMP,"},
1473 {SVs_OBJECT, "OBJECT,"},
1482 const struct flag_to_name second_sv_flags_names[] = {
1484 {SVf_FAKE, "FAKE,"},
1485 {SVf_READONLY, "READONLY,"},
1486 {SVf_BREAK, "BREAK,"},
1487 {SVf_AMAGIC, "OVERLOAD,"},
1493 const struct flag_to_name cv_flags_names[] = {
1494 {CVf_ANON, "ANON,"},
1495 {CVf_UNIQUE, "UNIQUE,"},
1496 {CVf_CLONE, "CLONE,"},
1497 {CVf_CLONED, "CLONED,"},
1498 {CVf_CONST, "CONST,"},
1499 {CVf_NODEBUG, "NODEBUG,"},
1500 {CVf_LVALUE, "LVALUE,"},
1501 {CVf_METHOD, "METHOD,"},
1502 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"}
1505 const struct flag_to_name hv_flags_names[] = {
1506 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1507 {SVphv_LAZYDEL, "LAZYDEL,"},
1508 {SVphv_HASKFLAGS, "HASKFLAGS,"},
1509 {SVphv_REHASH, "REHASH,"},
1510 {SVphv_CLONEABLE, "CLONEABLE,"}
1513 const struct flag_to_name gp_flags_names[] = {
1514 {GVf_INTRO, "INTRO,"},
1515 {GVf_MULTI, "MULTI,"},
1516 {GVf_ASSUMECV, "ASSUMECV,"},
1517 {GVf_IN_PAD, "IN_PAD,"}
1520 const struct flag_to_name gp_flags_imported_names[] = {
1521 {GVf_IMPORTED_SV, " SV"},
1522 {GVf_IMPORTED_AV, " AV"},
1523 {GVf_IMPORTED_HV, " HV"},
1524 {GVf_IMPORTED_CV, " CV"},
1528 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1536 PERL_ARGS_ASSERT_DO_SV_DUMP;
1539 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1543 flags = SvFLAGS(sv);
1546 d = Perl_newSVpvf(aTHX_
1547 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1548 PTR2UV(SvANY(sv)), PTR2UV(sv),
1549 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1550 (int)(PL_dumpindent*level), "");
1552 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1553 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1555 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1556 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1557 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1559 append_flags(d, flags, first_sv_flags_names);
1560 if (flags & SVf_ROK) {
1561 sv_catpv(d, "ROK,");
1562 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1564 append_flags(d, flags, second_sv_flags_names);
1565 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1566 if (SvPCS_IMPORTED(sv))
1567 sv_catpv(d, "PCS_IMPORTED,");
1569 sv_catpv(d, "SCREAM,");
1575 append_flags(d, CvFLAGS(sv), cv_flags_names);
1576 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1579 append_flags(d, flags, hv_flags_names);
1583 if (isGV_with_GP(sv)) {
1584 append_flags(d, GvFLAGS(sv), gp_flags_names);
1586 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1587 sv_catpv(d, "IMPORT");
1588 if (GvIMPORTED(sv) == GVf_IMPORTED)
1589 sv_catpv(d, "ALL,");
1592 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1596 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1597 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1601 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1602 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1605 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1606 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1609 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1614 /* SVphv_SHAREKEYS is also 0x20000000 */
1615 if ((type != SVt_PVHV) && SvUTF8(sv))
1616 sv_catpv(d, "UTF8");
1618 if (*(SvEND(d) - 1) == ',') {
1619 SvCUR_set(d, SvCUR(d) - 1);
1620 SvPVX(d)[SvCUR(d)] = '\0';
1625 #ifdef DEBUG_LEAKING_SCALARS
1626 Perl_dump_indent(aTHX_ level, file,
1627 "ALLOCATED at %s:%d %s %s%s; serial %"UVuf"\n",
1628 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1630 sv->sv_debug_inpad ? "for" : "by",
1631 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1632 sv->sv_debug_cloned ? " (cloned)" : "",
1636 Perl_dump_indent(aTHX_ level, file, "SV = ");
1637 if (type < SVt_LAST) {
1638 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1640 if (type == SVt_NULL) {
1645 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1649 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1650 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM
1651 && type != SVt_PVIO && type != SVt_REGEXP)
1652 || (type == SVt_IV && !SvROK(sv))) {
1654 #ifdef PERL_OLD_COPY_ON_WRITE
1658 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1660 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1661 #ifdef PERL_OLD_COPY_ON_WRITE
1662 if (SvIsCOW_shared_hash(sv))
1663 PerlIO_printf(file, " (HASH)");
1664 else if (SvIsCOW_normal(sv))
1665 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1667 PerlIO_putc(file, '\n');
1669 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1670 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1671 (UV) COP_SEQ_RANGE_LOW(sv));
1672 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1673 (UV) COP_SEQ_RANGE_HIGH(sv));
1674 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1675 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1676 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1677 || type == SVt_NV) {
1678 STORE_NUMERIC_LOCAL_SET_STANDARD();
1679 /* %Vg doesn't work? --jhi */
1680 #ifdef USE_LONG_DOUBLE
1681 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1683 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1685 RESTORE_NUMERIC_LOCAL();
1688 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1690 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1692 if (type < SVt_PV) {
1696 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1697 if (SvPVX_const(sv)) {
1700 SvOOK_offset(sv, delta);
1701 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1706 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1708 PerlIO_printf(file, "( %s . ) ",
1709 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1712 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1713 if (SvUTF8(sv)) /* the 6? \x{....} */
1714 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1715 PerlIO_printf(file, "\n");
1716 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1717 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1720 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1722 if (type == SVt_REGEXP) {
1724 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1725 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1728 if (type >= SVt_PVMG) {
1729 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1730 HV * const ost = SvOURSTASH(sv);
1732 do_hv_dump(level, file, " OURSTASH", ost);
1735 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1738 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1742 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1743 if (AvARRAY(sv) != AvALLOC(sv)) {
1744 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1745 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1748 PerlIO_putc(file, '\n');
1749 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1750 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1751 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1753 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1754 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1755 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1756 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1757 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1759 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1760 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1762 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1764 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1769 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1770 if (HvARRAY(sv) && HvKEYS(sv)) {
1771 /* Show distribution of HEs in the ARRAY */
1773 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1776 U32 pow2 = 2, keys = HvKEYS(sv);
1777 NV theoret, sum = 0;
1779 PerlIO_printf(file, " (");
1780 Zero(freq, FREQ_MAX + 1, int);
1781 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1784 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1786 if (count > FREQ_MAX)
1792 for (i = 0; i <= max; i++) {
1794 PerlIO_printf(file, "%d%s:%d", i,
1795 (i == FREQ_MAX) ? "+" : "",
1798 PerlIO_printf(file, ", ");
1801 PerlIO_putc(file, ')');
1802 /* The "quality" of a hash is defined as the total number of
1803 comparisons needed to access every element once, relative
1804 to the expected number needed for a random hash.
1806 The total number of comparisons is equal to the sum of
1807 the squares of the number of entries in each bucket.
1808 For a random hash of n keys into k buckets, the expected
1813 for (i = max; i > 0; i--) { /* Precision: count down. */
1814 sum += freq[i] * i * i;
1816 while ((keys = keys >> 1))
1818 theoret = HvKEYS(sv);
1819 theoret += theoret * (theoret-1)/pow2;
1820 PerlIO_putc(file, '\n');
1821 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1823 PerlIO_putc(file, '\n');
1824 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1825 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1826 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1827 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1828 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1830 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1831 if (mg && mg->mg_obj) {
1832 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1836 const char * const hvname = HvNAME_get(sv);
1838 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1842 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1843 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1845 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1847 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1851 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1852 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1853 (int)meta->mro_which->length,
1854 meta->mro_which->name,
1855 PTR2UV(meta->mro_which));
1856 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1857 (UV)meta->cache_gen);
1858 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1860 if (meta->mro_linear_all) {
1861 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1862 PTR2UV(meta->mro_linear_all));
1863 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1866 if (meta->mro_linear_current) {
1867 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1868 PTR2UV(meta->mro_linear_current));
1869 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1872 if (meta->mro_nextmethod) {
1873 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1874 PTR2UV(meta->mro_nextmethod));
1875 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1879 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1881 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1886 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1888 HV * const hv = MUTABLE_HV(sv);
1889 int count = maxnest - nest;
1892 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1895 const U32 hash = HeHASH(he);
1896 SV * const keysv = hv_iterkeysv(he);
1897 const char * const keypv = SvPV_const(keysv, len);
1898 SV * const elt = hv_iterval(hv, he);
1900 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1902 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1904 PerlIO_printf(file, "[REHASH] ");
1905 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1906 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1908 hv_iterinit(hv); /* Return to status quo */
1914 const char *const proto = SvPV_const(sv, len);
1915 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1920 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1921 if (!CvISXSUB(sv)) {
1923 Perl_dump_indent(aTHX_ level, file,
1924 " START = 0x%"UVxf" ===> %"IVdf"\n",
1925 PTR2UV(CvSTART(sv)),
1926 (IV)sequence_num(CvSTART(sv)));
1928 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1929 PTR2UV(CvROOT(sv)));
1930 if (CvROOT(sv) && dumpops) {
1931 do_op_dump(level+1, file, CvROOT(sv));
1934 SV * const constant = cv_const_sv((const CV *)sv);
1936 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1939 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1941 PTR2UV(CvXSUBANY(sv).any_ptr));
1942 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1945 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1946 (IV)CvXSUBANY(sv).any_i32);
1949 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1950 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1951 if (type == SVt_PVCV)
1952 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1953 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1954 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1955 if (type == SVt_PVFM)
1956 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1957 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1958 if (nest < maxnest) {
1959 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1962 const CV * const outside = CvOUTSIDE(sv);
1963 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1966 : CvANON(outside) ? "ANON"
1967 : (outside == PL_main_cv) ? "MAIN"
1968 : CvUNIQUE(outside) ? "UNIQUE"
1969 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1971 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1972 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1976 if (type == SVt_PVLV) {
1977 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1978 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1979 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1980 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1981 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1982 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1986 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1987 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1988 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1989 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1991 if (!isGV_with_GP(sv))
1993 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1994 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1995 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1996 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1999 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2000 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2001 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2002 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2003 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2004 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2005 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2006 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2007 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
2008 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
2009 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2010 do_gv_dump (level, file, " EGV", GvEGV(sv));
2013 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2014 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2015 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2016 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2017 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2018 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2019 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2021 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2022 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2023 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2025 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2026 PTR2UV(IoTOP_GV(sv)));
2027 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2028 maxnest, dumpops, pvlim);
2030 /* Source filters hide things that are not GVs in these three, so let's
2031 be careful out there. */
2033 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2034 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2035 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2037 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2038 PTR2UV(IoFMT_GV(sv)));
2039 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2040 maxnest, dumpops, pvlim);
2042 if (IoBOTTOM_NAME(sv))
2043 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2044 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2045 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2047 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2048 PTR2UV(IoBOTTOM_GV(sv)));
2049 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2050 maxnest, dumpops, pvlim);
2052 if (isPRINT(IoTYPE(sv)))
2053 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
2055 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
2056 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2063 Perl_sv_dump(pTHX_ SV *sv)
2067 PERL_ARGS_ASSERT_SV_DUMP;
2070 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2072 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2076 Perl_runops_debug(pTHX)
2080 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2084 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2087 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2088 PerlIO_printf(Perl_debug_log,
2089 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2090 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2091 PTR2UV(*PL_watchaddr));
2092 if (DEBUG_s_TEST_) {
2093 if (DEBUG_v_TEST_) {
2094 PerlIO_printf(Perl_debug_log, "\n");
2102 if (DEBUG_t_TEST_) debop(PL_op);
2103 if (DEBUG_P_TEST_) debprof(PL_op);
2105 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2106 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2113 Perl_debop(pTHX_ const OP *o)
2117 PERL_ARGS_ASSERT_DEBOP;
2119 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2122 Perl_deb(aTHX_ "%s", OP_NAME(o));
2123 switch (o->op_type) {
2126 /* With ITHREADS, consts are stored in the pad, and the right pad
2127 * may not be active here, so check.
2128 * Looks like only during compiling the pads are illegal.
2131 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2133 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2138 SV * const sv = newSV(0);
2140 /* FIXME - is this making unwarranted assumptions about the
2141 UTF-8 cleanliness of the dump file handle? */
2144 gv_fullname3(sv, cGVOPo_gv, NULL);
2145 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2149 PerlIO_printf(Perl_debug_log, "(NULL)");
2155 /* print the lexical's name */
2156 CV * const cv = deb_curcv(cxstack_ix);
2159 AV * const padlist = CvPADLIST(cv);
2160 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2161 sv = *av_fetch(comppad, o->op_targ, FALSE);
2165 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2167 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2173 PerlIO_printf(Perl_debug_log, "\n");
2178 S_deb_curcv(pTHX_ const I32 ix)
2181 const PERL_CONTEXT * const cx = &cxstack[ix];
2182 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2183 return cx->blk_sub.cv;
2184 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2186 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2191 return deb_curcv(ix - 1);
2195 Perl_watch(pTHX_ char **addr)
2199 PERL_ARGS_ASSERT_WATCH;
2201 PL_watchaddr = addr;
2203 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2204 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2208 S_debprof(pTHX_ const OP *o)
2212 PERL_ARGS_ASSERT_DEBPROF;
2214 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2216 if (!PL_profiledata)
2217 Newxz(PL_profiledata, MAXO, U32);
2218 ++PL_profiledata[o->op_type];
2222 Perl_debprofdump(pTHX)
2226 if (!PL_profiledata)
2228 for (i = 0; i < MAXO; i++) {
2229 if (PL_profiledata[i])
2230 PerlIO_printf(Perl_debug_log,
2231 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2238 * XML variants of most of the above routines
2242 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2246 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2248 PerlIO_printf(file, "\n ");
2249 va_start(args, pat);
2250 xmldump_vindent(level, file, pat, &args);
2256 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2259 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2260 va_start(args, pat);
2261 xmldump_vindent(level, file, pat, &args);
2266 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2268 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2270 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2271 PerlIO_vprintf(file, pat, *args);
2275 Perl_xmldump_all(pTHX)
2277 xmldump_all_perl(FALSE);
2281 Perl_xmldump_all_perl(pTHX_ bool justperl)
2283 PerlIO_setlinebuf(PL_xmlfp);
2285 op_xmldump(PL_main_root);
2286 xmldump_packsubs_perl(PL_defstash, justperl);
2287 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2288 PerlIO_close(PL_xmlfp);
2293 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2295 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2296 xmldump_packsubs_perl(stash, FALSE);
2300 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2305 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2307 if (!HvARRAY(stash))
2309 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2310 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2311 GV *gv = MUTABLE_GV(HeVAL(entry));
2313 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2316 xmldump_sub_perl(gv, justperl);
2319 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2320 && (hv = GvHV(gv)) && hv != PL_defstash)
2321 xmldump_packsubs_perl(hv, justperl); /* nested package */
2327 Perl_xmldump_sub(pTHX_ const GV *gv)
2329 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2330 xmldump_sub_perl(gv, FALSE);
2334 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2338 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2340 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2343 sv = sv_newmortal();
2344 gv_fullname3(sv, gv, NULL);
2345 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2346 if (CvXSUB(GvCV(gv)))
2347 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2348 PTR2UV(CvXSUB(GvCV(gv))),
2349 (int)CvXSUBANY(GvCV(gv)).any_i32);
2350 else if (CvROOT(GvCV(gv)))
2351 op_xmldump(CvROOT(GvCV(gv)));
2353 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2357 Perl_xmldump_form(pTHX_ const GV *gv)
2359 SV * const sv = sv_newmortal();
2361 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2363 gv_fullname3(sv, gv, NULL);
2364 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2365 if (CvROOT(GvFORM(gv)))
2366 op_xmldump(CvROOT(GvFORM(gv)));
2368 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2372 Perl_xmldump_eval(pTHX)
2374 op_xmldump(PL_eval_root);
2378 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2380 PERL_ARGS_ASSERT_SV_CATXMLSV;
2381 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2385 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2388 const char * const e = pv + len;
2389 const char * const start = pv;
2393 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2396 dsvcur = SvCUR(dsv); /* in case we have to restart */
2401 c = utf8_to_uvchr((U8*)pv, &cl);
2403 SvCUR(dsv) = dsvcur;
2468 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2471 sv_catpvs(dsv, "<");
2474 sv_catpvs(dsv, ">");
2477 sv_catpvs(dsv, "&");
2480 sv_catpvs(dsv, """);
2484 if (c < 32 || c > 127) {
2485 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2488 const char string = (char) c;
2489 sv_catpvn(dsv, &string, 1);
2493 if ((c >= 0xD800 && c <= 0xDB7F) ||
2494 (c >= 0xDC00 && c <= 0xDFFF) ||
2495 (c >= 0xFFF0 && c <= 0xFFFF) ||
2497 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2499 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2512 Perl_sv_xmlpeek(pTHX_ SV *sv)
2514 SV * const t = sv_newmortal();
2518 PERL_ARGS_ASSERT_SV_XMLPEEK;
2524 sv_catpv(t, "VOID=\"\"");
2527 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2528 sv_catpv(t, "WILD=\"\"");
2531 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2532 if (sv == &PL_sv_undef) {
2533 sv_catpv(t, "SV_UNDEF=\"1\"");
2534 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2535 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2539 else if (sv == &PL_sv_no) {
2540 sv_catpv(t, "SV_NO=\"1\"");
2541 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2542 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2543 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2544 SVp_POK|SVp_NOK)) &&
2549 else if (sv == &PL_sv_yes) {
2550 sv_catpv(t, "SV_YES=\"1\"");
2551 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2552 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2553 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2554 SVp_POK|SVp_NOK)) &&
2556 SvPVX(sv) && *SvPVX(sv) == '1' &&
2561 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2562 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2563 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2567 sv_catpv(t, " XXX=\"\" ");
2569 else if (SvREFCNT(sv) == 0) {
2570 sv_catpv(t, " refcnt=\"0\"");
2573 else if (DEBUG_R_TEST_) {
2576 /* is this SV on the tmps stack? */
2577 for (ix=PL_tmps_ix; ix>=0; ix--) {
2578 if (PL_tmps_stack[ix] == sv) {
2583 if (SvREFCNT(sv) > 1)
2584 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2587 sv_catpv(t, " DRT=\"<T>\"");
2591 sv_catpv(t, " ROK=\"\"");
2593 switch (SvTYPE(sv)) {
2595 sv_catpv(t, " FREED=\"1\"");
2599 sv_catpv(t, " UNDEF=\"1\"");
2602 sv_catpv(t, " IV=\"");
2605 sv_catpv(t, " NV=\"");
2608 sv_catpv(t, " PV=\"");
2611 sv_catpv(t, " PVIV=\"");
2614 sv_catpv(t, " PVNV=\"");
2617 sv_catpv(t, " PVMG=\"");
2620 sv_catpv(t, " PVLV=\"");
2623 sv_catpv(t, " AV=\"");
2626 sv_catpv(t, " HV=\"");
2630 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2632 sv_catpv(t, " CV=\"()\"");
2635 sv_catpv(t, " GV=\"");
2638 sv_catpv(t, " BIND=\"");
2641 sv_catpv(t, " ORANGE=\"");
2644 sv_catpv(t, " FM=\"");
2647 sv_catpv(t, " IO=\"");
2656 else if (SvNOKp(sv)) {
2657 STORE_NUMERIC_LOCAL_SET_STANDARD();
2658 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2659 RESTORE_NUMERIC_LOCAL();
2661 else if (SvIOKp(sv)) {
2663 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2665 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2674 return SvPV(t, n_a);
2678 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2680 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2683 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2686 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2689 REGEXP *const r = PM_GETRE(pm);
2690 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2691 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2692 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2694 SvREFCNT_dec(tmpsv);
2695 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2696 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2699 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2700 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2701 SV * const tmpsv = pm_description(pm);
2702 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2703 SvREFCNT_dec(tmpsv);
2707 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2708 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2709 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2710 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2711 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2712 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2715 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2719 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2721 do_pmop_xmldump(0, PL_xmlfp, pm);
2725 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2730 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2735 seq = sequence_num(o);
2736 Perl_xmldump_indent(aTHX_ level, file,
2737 "<op_%s seq=\"%"UVuf" -> ",
2742 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2743 sequence_num(o->op_next));
2745 PerlIO_printf(file, "DONE\"");
2748 if (o->op_type == OP_NULL)
2750 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2751 if (o->op_targ == OP_NEXTSTATE)
2754 PerlIO_printf(file, " line=\"%"UVuf"\"",
2755 (UV)CopLINE(cCOPo));
2756 if (CopSTASHPV(cCOPo))
2757 PerlIO_printf(file, " package=\"%s\"",
2759 if (CopLABEL(cCOPo))
2760 PerlIO_printf(file, " label=\"%s\"",
2765 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2768 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2771 SV * const tmpsv = newSVpvs("");
2772 switch (o->op_flags & OPf_WANT) {
2774 sv_catpv(tmpsv, ",VOID");
2776 case OPf_WANT_SCALAR:
2777 sv_catpv(tmpsv, ",SCALAR");
2780 sv_catpv(tmpsv, ",LIST");
2783 sv_catpv(tmpsv, ",UNKNOWN");
2786 if (o->op_flags & OPf_KIDS)
2787 sv_catpv(tmpsv, ",KIDS");
2788 if (o->op_flags & OPf_PARENS)
2789 sv_catpv(tmpsv, ",PARENS");
2790 if (o->op_flags & OPf_STACKED)
2791 sv_catpv(tmpsv, ",STACKED");
2792 if (o->op_flags & OPf_REF)
2793 sv_catpv(tmpsv, ",REF");
2794 if (o->op_flags & OPf_MOD)
2795 sv_catpv(tmpsv, ",MOD");
2796 if (o->op_flags & OPf_SPECIAL)
2797 sv_catpv(tmpsv, ",SPECIAL");
2798 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2799 SvREFCNT_dec(tmpsv);
2801 if (o->op_private) {
2802 SV * const tmpsv = newSVpvs("");
2803 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2804 if (o->op_private & OPpTARGET_MY)
2805 sv_catpv(tmpsv, ",TARGET_MY");
2807 else if (o->op_type == OP_LEAVESUB ||
2808 o->op_type == OP_LEAVE ||
2809 o->op_type == OP_LEAVESUBLV ||
2810 o->op_type == OP_LEAVEWRITE) {
2811 if (o->op_private & OPpREFCOUNTED)
2812 sv_catpv(tmpsv, ",REFCOUNTED");
2814 else if (o->op_type == OP_AASSIGN) {
2815 if (o->op_private & OPpASSIGN_COMMON)
2816 sv_catpv(tmpsv, ",COMMON");
2818 else if (o->op_type == OP_SASSIGN) {
2819 if (o->op_private & OPpASSIGN_BACKWARDS)
2820 sv_catpv(tmpsv, ",BACKWARDS");
2822 else if (o->op_type == OP_TRANS) {
2823 if (o->op_private & OPpTRANS_SQUASH)
2824 sv_catpv(tmpsv, ",SQUASH");
2825 if (o->op_private & OPpTRANS_DELETE)
2826 sv_catpv(tmpsv, ",DELETE");
2827 if (o->op_private & OPpTRANS_COMPLEMENT)
2828 sv_catpv(tmpsv, ",COMPLEMENT");
2829 if (o->op_private & OPpTRANS_IDENTICAL)
2830 sv_catpv(tmpsv, ",IDENTICAL");
2831 if (o->op_private & OPpTRANS_GROWS)
2832 sv_catpv(tmpsv, ",GROWS");
2834 else if (o->op_type == OP_REPEAT) {
2835 if (o->op_private & OPpREPEAT_DOLIST)
2836 sv_catpv(tmpsv, ",DOLIST");
2838 else if (o->op_type == OP_ENTERSUB ||
2839 o->op_type == OP_RV2SV ||
2840 o->op_type == OP_GVSV ||
2841 o->op_type == OP_RV2AV ||
2842 o->op_type == OP_RV2HV ||
2843 o->op_type == OP_RV2GV ||
2844 o->op_type == OP_AELEM ||
2845 o->op_type == OP_HELEM )
2847 if (o->op_type == OP_ENTERSUB) {
2848 if (o->op_private & OPpENTERSUB_AMPER)
2849 sv_catpv(tmpsv, ",AMPER");
2850 if (o->op_private & OPpENTERSUB_DB)
2851 sv_catpv(tmpsv, ",DB");
2852 if (o->op_private & OPpENTERSUB_HASTARG)
2853 sv_catpv(tmpsv, ",HASTARG");
2854 if (o->op_private & OPpENTERSUB_NOPAREN)
2855 sv_catpv(tmpsv, ",NOPAREN");
2856 if (o->op_private & OPpENTERSUB_INARGS)
2857 sv_catpv(tmpsv, ",INARGS");
2858 if (o->op_private & OPpENTERSUB_NOMOD)
2859 sv_catpv(tmpsv, ",NOMOD");
2862 switch (o->op_private & OPpDEREF) {
2864 sv_catpv(tmpsv, ",SV");
2867 sv_catpv(tmpsv, ",AV");
2870 sv_catpv(tmpsv, ",HV");
2873 if (o->op_private & OPpMAYBE_LVSUB)
2874 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2876 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2877 if (o->op_private & OPpLVAL_DEFER)
2878 sv_catpv(tmpsv, ",LVAL_DEFER");
2881 if (o->op_private & HINT_STRICT_REFS)
2882 sv_catpv(tmpsv, ",STRICT_REFS");
2883 if (o->op_private & OPpOUR_INTRO)
2884 sv_catpv(tmpsv, ",OUR_INTRO");
2887 else if (o->op_type == OP_CONST) {
2888 if (o->op_private & OPpCONST_BARE)
2889 sv_catpv(tmpsv, ",BARE");
2890 if (o->op_private & OPpCONST_STRICT)
2891 sv_catpv(tmpsv, ",STRICT");
2892 if (o->op_private & OPpCONST_ARYBASE)
2893 sv_catpv(tmpsv, ",ARYBASE");
2894 if (o->op_private & OPpCONST_WARNING)
2895 sv_catpv(tmpsv, ",WARNING");
2896 if (o->op_private & OPpCONST_ENTERED)
2897 sv_catpv(tmpsv, ",ENTERED");
2899 else if (o->op_type == OP_FLIP) {
2900 if (o->op_private & OPpFLIP_LINENUM)
2901 sv_catpv(tmpsv, ",LINENUM");
2903 else if (o->op_type == OP_FLOP) {
2904 if (o->op_private & OPpFLIP_LINENUM)
2905 sv_catpv(tmpsv, ",LINENUM");
2907 else if (o->op_type == OP_RV2CV) {
2908 if (o->op_private & OPpLVAL_INTRO)
2909 sv_catpv(tmpsv, ",INTRO");
2911 else if (o->op_type == OP_GV) {
2912 if (o->op_private & OPpEARLY_CV)
2913 sv_catpv(tmpsv, ",EARLY_CV");
2915 else if (o->op_type == OP_LIST) {
2916 if (o->op_private & OPpLIST_GUESSED)
2917 sv_catpv(tmpsv, ",GUESSED");
2919 else if (o->op_type == OP_DELETE) {
2920 if (o->op_private & OPpSLICE)
2921 sv_catpv(tmpsv, ",SLICE");
2923 else if (o->op_type == OP_EXISTS) {
2924 if (o->op_private & OPpEXISTS_SUB)
2925 sv_catpv(tmpsv, ",EXISTS_SUB");
2927 else if (o->op_type == OP_SORT) {
2928 if (o->op_private & OPpSORT_NUMERIC)
2929 sv_catpv(tmpsv, ",NUMERIC");
2930 if (o->op_private & OPpSORT_INTEGER)
2931 sv_catpv(tmpsv, ",INTEGER");
2932 if (o->op_private & OPpSORT_REVERSE)
2933 sv_catpv(tmpsv, ",REVERSE");
2935 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2936 if (o->op_private & OPpOPEN_IN_RAW)
2937 sv_catpv(tmpsv, ",IN_RAW");
2938 if (o->op_private & OPpOPEN_IN_CRLF)
2939 sv_catpv(tmpsv, ",IN_CRLF");
2940 if (o->op_private & OPpOPEN_OUT_RAW)
2941 sv_catpv(tmpsv, ",OUT_RAW");
2942 if (o->op_private & OPpOPEN_OUT_CRLF)
2943 sv_catpv(tmpsv, ",OUT_CRLF");
2945 else if (o->op_type == OP_EXIT) {
2946 if (o->op_private & OPpEXIT_VMSISH)
2947 sv_catpv(tmpsv, ",EXIT_VMSISH");
2948 if (o->op_private & OPpHUSH_VMSISH)
2949 sv_catpv(tmpsv, ",HUSH_VMSISH");
2951 else if (o->op_type == OP_DIE) {
2952 if (o->op_private & OPpHUSH_VMSISH)
2953 sv_catpv(tmpsv, ",HUSH_VMSISH");
2955 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2956 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2957 sv_catpv(tmpsv, ",FT_ACCESS");
2958 if (o->op_private & OPpFT_STACKED)
2959 sv_catpv(tmpsv, ",FT_STACKED");
2961 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2962 sv_catpv(tmpsv, ",INTRO");
2964 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2965 SvREFCNT_dec(tmpsv);
2968 switch (o->op_type) {
2970 if (o->op_flags & OPf_SPECIAL) {
2976 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2978 if (cSVOPo->op_sv) {
2979 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2980 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2986 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2987 s = SvPV(tmpsv1,len);
2988 sv_catxmlpvn(tmpsv2, s, len, 1);
2989 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2993 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2998 case OP_METHOD_NAMED:
2999 #ifndef USE_ITHREADS
3000 /* with ITHREADS, consts are stored in the pad, and the right pad
3001 * may not be active here, so skip */
3002 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3008 PerlIO_printf(file, ">\n");
3010 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3015 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3016 (UV)CopLINE(cCOPo));
3017 if (CopSTASHPV(cCOPo))
3018 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3020 if (CopLABEL(cCOPo))
3021 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3025 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3026 if (cLOOPo->op_redoop)
3027 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3029 PerlIO_printf(file, "DONE\"");
3030 S_xmldump_attr(aTHX_ level, file, "next=\"");
3031 if (cLOOPo->op_nextop)
3032 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3034 PerlIO_printf(file, "DONE\"");
3035 S_xmldump_attr(aTHX_ level, file, "last=\"");
3036 if (cLOOPo->op_lastop)
3037 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3039 PerlIO_printf(file, "DONE\"");
3047 S_xmldump_attr(aTHX_ level, file, "other=\"");
3048 if (cLOGOPo->op_other)
3049 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3051 PerlIO_printf(file, "DONE\"");
3059 if (o->op_private & OPpREFCOUNTED)
3060 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3066 if (PL_madskills && o->op_madprop) {
3067 char prevkey = '\0';
3068 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3069 const MADPROP* mp = o->op_madprop;
3073 PerlIO_printf(file, ">\n");
3075 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3078 char tmp = mp->mad_key;
3079 sv_setpvs(tmpsv,"\"");
3081 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3082 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3083 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3086 sv_catpv(tmpsv, "\"");
3087 switch (mp->mad_type) {
3089 sv_catpv(tmpsv, "NULL");
3090 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3093 sv_catpv(tmpsv, " val=\"");
3094 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3095 sv_catpv(tmpsv, "\"");
3096 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3099 sv_catpv(tmpsv, " val=\"");
3100 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3101 sv_catpv(tmpsv, "\"");
3102 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3105 if ((OP*)mp->mad_val) {
3106 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3107 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3108 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3112 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3118 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3120 SvREFCNT_dec(tmpsv);
3123 switch (o->op_type) {
3130 PerlIO_printf(file, ">\n");
3132 do_pmop_xmldump(level, file, cPMOPo);
3138 if (o->op_flags & OPf_KIDS) {
3142 PerlIO_printf(file, ">\n");
3144 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3145 do_op_xmldump(level, file, kid);
3149 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3151 PerlIO_printf(file, " />\n");
3155 Perl_op_xmldump(pTHX_ const OP *o)
3157 PERL_ARGS_ASSERT_OP_XMLDUMP;
3159 do_op_xmldump(0, PL_xmlfp, o);
3165 * c-indentation-style: bsd
3167 * indent-tabs-mode: t
3170 * ex: set ts=8 sts=4 sw=4 noet: