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] = {
71 #define Sequence PL_op_sequence
74 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
77 PERL_ARGS_ASSERT_DUMP_INDENT;
79 dump_vindent(level, file, pat, &args);
84 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
87 PERL_ARGS_ASSERT_DUMP_VINDENT;
88 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
89 PerlIO_vprintf(file, pat, *args);
96 PerlIO_setlinebuf(Perl_debug_log);
98 op_dump(PL_main_root);
99 dump_packsubs(PL_defstash);
103 Perl_dump_packsubs(pTHX_ const HV *stash)
108 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
112 for (i = 0; i <= (I32) HvMAX(stash); i++) {
114 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
115 const GV * const gv = (const GV *)HeVAL(entry);
116 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
122 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
123 const HV * const hv = GvHV(gv);
124 if (hv && (hv != PL_defstash))
125 dump_packsubs(hv); /* nested package */
132 Perl_dump_sub(pTHX_ const GV *gv)
134 SV * const sv = sv_newmortal();
136 PERL_ARGS_ASSERT_DUMP_SUB;
138 gv_fullname3(sv, gv, NULL);
139 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
140 if (CvISXSUB(GvCV(gv)))
141 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
142 PTR2UV(CvXSUB(GvCV(gv))),
143 (int)CvXSUBANY(GvCV(gv)).any_i32);
144 else if (CvROOT(GvCV(gv)))
145 op_dump(CvROOT(GvCV(gv)));
147 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
151 Perl_dump_form(pTHX_ const GV *gv)
153 SV * const sv = sv_newmortal();
155 PERL_ARGS_ASSERT_DUMP_FORM;
157 gv_fullname3(sv, gv, NULL);
158 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
159 if (CvROOT(GvFORM(gv)))
160 op_dump(CvROOT(GvFORM(gv)));
162 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
169 op_dump(PL_eval_root);
174 =for apidoc pv_escape
176 Escapes at most the first "count" chars of pv and puts the results into
177 dsv such that the size of the escaped string will not exceed "max" chars
178 and will not contain any incomplete escape sequences.
180 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
181 will also be escaped.
183 Normally the SV will be cleared before the escaped string is prepared,
184 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
186 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
187 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
188 using C<is_utf8_string()> to determine if it is Unicode.
190 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
191 using C<\x01F1> style escapes, otherwise only chars above 255 will be
192 escaped using this style, other non printable chars will use octal or
193 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
194 then all chars below 255 will be treated as printable and
195 will be output as literals.
197 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
198 string will be escaped, regardles of max. If the string is utf8 and
199 the chars value is >255 then it will be returned as a plain hex
200 sequence. Thus the output will either be a single char,
201 an octal escape sequence, a special escape like C<\n> or a 3 or
202 more digit hex value.
204 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
205 not a '\\'. This is because regexes very often contain backslashed
206 sequences, whereas '%' is not a particularly common character in patterns.
208 Returns a pointer to the escaped text as held by dsv.
212 #define PV_ESCAPE_OCTBUFSIZE 32
215 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
216 const STRLEN count, const STRLEN max,
217 STRLEN * const escaped, const U32 flags )
219 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
220 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
221 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
222 STRLEN wrote = 0; /* chars written so far */
223 STRLEN chsize = 0; /* size of data to be written */
224 STRLEN readsize = 1; /* size of data just read */
225 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
226 const char *pv = str;
227 const char * const end = pv + count; /* end of string */
230 PERL_ARGS_ASSERT_PV_ESCAPE;
232 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
233 /* This won't alter the UTF-8 flag */
237 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
240 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
241 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
242 const U8 c = (U8)u & 0xFF;
244 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
245 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
246 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
249 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
250 "%cx{%"UVxf"}", esc, u);
251 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
254 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
258 case '\\' : /* fallthrough */
259 case '%' : if ( c == esc ) {
265 case '\v' : octbuf[1] = 'v'; break;
266 case '\t' : octbuf[1] = 't'; break;
267 case '\r' : octbuf[1] = 'r'; break;
268 case '\n' : octbuf[1] = 'n'; break;
269 case '\f' : octbuf[1] = 'f'; break;
277 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
278 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
281 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
288 if ( max && (wrote + chsize > max) ) {
290 } else if (chsize > 1) {
291 sv_catpvn(dsv, octbuf, chsize);
294 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
295 128-255 can be appended raw to the dsv. If dsv happens to be
296 UTF-8 then we need catpvf to upgrade them for us.
297 Or add a new API call sv_catpvc(). Think about that name, and
298 how to keep it clear that it's unlike the s of catpvs, which is
299 really an array octets, not a string. */
300 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
303 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
311 =for apidoc pv_pretty
313 Converts a string into something presentable, handling escaping via
314 pv_escape() and supporting quoting and ellipses.
316 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
317 double quoted with any double quotes in the string escaped. Otherwise
318 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
321 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
322 string were output then an ellipsis C<...> will be appended to the
323 string. Note that this happens AFTER it has been quoted.
325 If start_color is non-null then it will be inserted after the opening
326 quote (if there is one) but before the escaped text. If end_color
327 is non-null then it will be inserted after the escaped text but before
328 any quotes or ellipses.
330 Returns a pointer to the prettified text as held by dsv.
336 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
337 const STRLEN max, char const * const start_color, char const * const end_color,
340 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
343 PERL_ARGS_ASSERT_PV_PRETTY;
345 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
346 /* This won't alter the UTF-8 flag */
351 sv_catpvs(dsv, "\"");
352 else if ( flags & PERL_PV_PRETTY_LTGT )
355 if ( start_color != NULL )
356 sv_catpv(dsv, start_color);
358 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
360 if ( end_color != NULL )
361 sv_catpv(dsv, end_color);
364 sv_catpvs( dsv, "\"");
365 else if ( flags & PERL_PV_PRETTY_LTGT )
368 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
369 sv_catpvs(dsv, "...");
375 =for apidoc pv_display
379 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
381 except that an additional "\0" will be appended to the string when
382 len > cur and pv[cur] is "\0".
384 Note that the final string may be up to 7 chars longer than pvlim.
390 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
392 PERL_ARGS_ASSERT_PV_DISPLAY;
394 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
395 if (len > cur && pv[cur] == '\0')
396 sv_catpvs( dsv, "\\0");
401 Perl_sv_peek(pTHX_ SV *sv)
404 SV * const t = sv_newmortal();
414 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
418 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
419 if (sv == &PL_sv_undef) {
420 sv_catpv(t, "SV_UNDEF");
421 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
422 SVs_GMG|SVs_SMG|SVs_RMG)) &&
426 else if (sv == &PL_sv_no) {
427 sv_catpv(t, "SV_NO");
428 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
429 SVs_GMG|SVs_SMG|SVs_RMG)) &&
430 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
436 else if (sv == &PL_sv_yes) {
437 sv_catpv(t, "SV_YES");
438 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
439 SVs_GMG|SVs_SMG|SVs_RMG)) &&
440 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
443 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
448 sv_catpv(t, "SV_PLACEHOLDER");
449 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
450 SVs_GMG|SVs_SMG|SVs_RMG)) &&
456 else if (SvREFCNT(sv) == 0) {
460 else if (DEBUG_R_TEST_) {
463 /* is this SV on the tmps stack? */
464 for (ix=PL_tmps_ix; ix>=0; ix--) {
465 if (PL_tmps_stack[ix] == sv) {
470 if (SvREFCNT(sv) > 1)
471 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
479 if (SvCUR(t) + unref > 10) {
480 SvCUR_set(t, unref + 3);
489 if (type == SVt_PVCV) {
490 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
492 } else if (type < SVt_LAST) {
493 sv_catpv(t, svshorttypenames[type]);
495 if (type == SVt_NULL)
498 sv_catpv(t, "FREED");
503 if (!SvPVX_const(sv))
504 sv_catpv(t, "(null)");
506 SV * const tmp = newSVpvs("");
510 SvOOK_offset(sv, delta);
511 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
513 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
515 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
516 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
521 else if (SvNOKp(sv)) {
522 STORE_NUMERIC_LOCAL_SET_STANDARD();
523 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
524 RESTORE_NUMERIC_LOCAL();
526 else if (SvIOKp(sv)) {
528 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
530 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
538 if (PL_tainting && SvTAINTED(sv))
539 sv_catpv(t, " [tainted]");
540 return SvPV_nolen(t);
544 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
548 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
551 Perl_dump_indent(aTHX_ level, file, "{}\n");
554 Perl_dump_indent(aTHX_ level, file, "{\n");
556 if (pm->op_pmflags & PMf_ONCE)
561 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
562 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
563 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
565 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
566 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
567 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
568 op_dump(pm->op_pmreplrootu.op_pmreplroot);
570 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
571 SV * const tmpsv = pm_description(pm);
572 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
576 Perl_dump_indent(aTHX_ level-1, file, "}\n");
580 S_pm_description(pTHX_ const PMOP *pm)
582 SV * const desc = newSVpvs("");
583 const REGEXP * const regex = PM_GETRE(pm);
584 const U32 pmflags = pm->op_pmflags;
586 PERL_ARGS_ASSERT_PM_DESCRIPTION;
588 if (pmflags & PMf_ONCE)
589 sv_catpv(desc, ",ONCE");
591 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
592 sv_catpv(desc, ":USED");
594 if (pmflags & PMf_USED)
595 sv_catpv(desc, ":USED");
599 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
600 sv_catpv(desc, ",TAINTED");
601 if (RX_CHECK_SUBSTR(regex)) {
602 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
603 sv_catpv(desc, ",SCANFIRST");
604 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
605 sv_catpv(desc, ",ALL");
607 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
608 sv_catpv(desc, ",SKIPWHITE");
611 if (pmflags & PMf_CONST)
612 sv_catpv(desc, ",CONST");
613 if (pmflags & PMf_KEEP)
614 sv_catpv(desc, ",KEEP");
615 if (pmflags & PMf_GLOBAL)
616 sv_catpv(desc, ",GLOBAL");
617 if (pmflags & PMf_CONTINUE)
618 sv_catpv(desc, ",CONTINUE");
619 if (pmflags & PMf_RETAINT)
620 sv_catpv(desc, ",RETAINT");
621 if (pmflags & PMf_EVAL)
622 sv_catpv(desc, ",EVAL");
627 Perl_pmop_dump(pTHX_ PMOP *pm)
629 do_pmop_dump(0, Perl_debug_log, pm);
632 /* An op sequencer. We visit the ops in the order they're to execute. */
635 S_sequence(pTHX_ register const OP *o)
638 const OP *oldop = NULL;
651 for (; o; o = o->op_next) {
653 SV * const op = newSVuv(PTR2UV(o));
654 const char * const key = SvPV_const(op, len);
656 if (hv_exists(Sequence, key, len))
659 switch (o->op_type) {
661 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
662 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
671 if (oldop && o->op_next)
678 if (oldop && o->op_next)
680 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
693 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
694 sequence_tail(cLOGOPo->op_other);
699 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
700 sequence_tail(cLOOPo->op_redoop);
701 sequence_tail(cLOOPo->op_nextop);
702 sequence_tail(cLOOPo->op_lastop);
706 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
707 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
716 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
724 S_sequence_tail(pTHX_ const OP *o)
726 while (o && (o->op_type == OP_NULL))
732 S_sequence_num(pTHX_ const OP *o)
740 op = newSVuv(PTR2UV(o));
741 key = SvPV_const(op, len);
742 seq = hv_fetch(Sequence, key, len, 0);
743 return seq ? SvUV(*seq): 0;
747 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
751 const OPCODE optype = o->op_type;
753 PERL_ARGS_ASSERT_DO_OP_DUMP;
756 Perl_dump_indent(aTHX_ level, file, "{\n");
758 seq = sequence_num(o);
760 PerlIO_printf(file, "%-4"UVuf, seq);
762 PerlIO_printf(file, " ");
764 "%*sTYPE = %s ===> ",
765 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
767 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
768 sequence_num(o->op_next));
770 PerlIO_printf(file, "DONE\n");
772 if (optype == OP_NULL) {
773 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
774 if (o->op_targ == OP_NEXTSTATE) {
776 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
778 if (CopSTASHPV(cCOPo))
779 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
782 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
787 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
790 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
792 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
793 SV * const tmpsv = newSVpvs("");
794 switch (o->op_flags & OPf_WANT) {
796 sv_catpv(tmpsv, ",VOID");
798 case OPf_WANT_SCALAR:
799 sv_catpv(tmpsv, ",SCALAR");
802 sv_catpv(tmpsv, ",LIST");
805 sv_catpv(tmpsv, ",UNKNOWN");
808 if (o->op_flags & OPf_KIDS)
809 sv_catpv(tmpsv, ",KIDS");
810 if (o->op_flags & OPf_PARENS)
811 sv_catpv(tmpsv, ",PARENS");
812 if (o->op_flags & OPf_STACKED)
813 sv_catpv(tmpsv, ",STACKED");
814 if (o->op_flags & OPf_REF)
815 sv_catpv(tmpsv, ",REF");
816 if (o->op_flags & OPf_MOD)
817 sv_catpv(tmpsv, ",MOD");
818 if (o->op_flags & OPf_SPECIAL)
819 sv_catpv(tmpsv, ",SPECIAL");
821 sv_catpv(tmpsv, ",LATEFREE");
823 sv_catpv(tmpsv, ",LATEFREED");
825 sv_catpv(tmpsv, ",ATTACHED");
826 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
830 SV * const tmpsv = newSVpvs("");
831 if (PL_opargs[optype] & OA_TARGLEX) {
832 if (o->op_private & OPpTARGET_MY)
833 sv_catpv(tmpsv, ",TARGET_MY");
835 else if (optype == OP_LEAVESUB ||
836 optype == OP_LEAVE ||
837 optype == OP_LEAVESUBLV ||
838 optype == OP_LEAVEWRITE) {
839 if (o->op_private & OPpREFCOUNTED)
840 sv_catpv(tmpsv, ",REFCOUNTED");
842 else if (optype == OP_AASSIGN) {
843 if (o->op_private & OPpASSIGN_COMMON)
844 sv_catpv(tmpsv, ",COMMON");
846 else if (optype == OP_SASSIGN) {
847 if (o->op_private & OPpASSIGN_BACKWARDS)
848 sv_catpv(tmpsv, ",BACKWARDS");
850 else if (optype == OP_TRANS) {
851 if (o->op_private & OPpTRANS_SQUASH)
852 sv_catpv(tmpsv, ",SQUASH");
853 if (o->op_private & OPpTRANS_DELETE)
854 sv_catpv(tmpsv, ",DELETE");
855 if (o->op_private & OPpTRANS_COMPLEMENT)
856 sv_catpv(tmpsv, ",COMPLEMENT");
857 if (o->op_private & OPpTRANS_IDENTICAL)
858 sv_catpv(tmpsv, ",IDENTICAL");
859 if (o->op_private & OPpTRANS_GROWS)
860 sv_catpv(tmpsv, ",GROWS");
862 else if (optype == OP_REPEAT) {
863 if (o->op_private & OPpREPEAT_DOLIST)
864 sv_catpv(tmpsv, ",DOLIST");
866 else if (optype == OP_ENTERSUB ||
867 optype == OP_RV2SV ||
869 optype == OP_RV2AV ||
870 optype == OP_RV2HV ||
871 optype == OP_RV2GV ||
872 optype == OP_AELEM ||
875 if (optype == OP_ENTERSUB) {
876 if (o->op_private & OPpENTERSUB_AMPER)
877 sv_catpv(tmpsv, ",AMPER");
878 if (o->op_private & OPpENTERSUB_DB)
879 sv_catpv(tmpsv, ",DB");
880 if (o->op_private & OPpENTERSUB_HASTARG)
881 sv_catpv(tmpsv, ",HASTARG");
882 if (o->op_private & OPpENTERSUB_NOPAREN)
883 sv_catpv(tmpsv, ",NOPAREN");
884 if (o->op_private & OPpENTERSUB_INARGS)
885 sv_catpv(tmpsv, ",INARGS");
886 if (o->op_private & OPpENTERSUB_NOMOD)
887 sv_catpv(tmpsv, ",NOMOD");
890 switch (o->op_private & OPpDEREF) {
892 sv_catpv(tmpsv, ",SV");
895 sv_catpv(tmpsv, ",AV");
898 sv_catpv(tmpsv, ",HV");
901 if (o->op_private & OPpMAYBE_LVSUB)
902 sv_catpv(tmpsv, ",MAYBE_LVSUB");
904 if (optype == OP_AELEM || optype == OP_HELEM) {
905 if (o->op_private & OPpLVAL_DEFER)
906 sv_catpv(tmpsv, ",LVAL_DEFER");
909 if (o->op_private & HINT_STRICT_REFS)
910 sv_catpv(tmpsv, ",STRICT_REFS");
911 if (o->op_private & OPpOUR_INTRO)
912 sv_catpv(tmpsv, ",OUR_INTRO");
915 else if (optype == OP_CONST) {
916 if (o->op_private & OPpCONST_BARE)
917 sv_catpv(tmpsv, ",BARE");
918 if (o->op_private & OPpCONST_STRICT)
919 sv_catpv(tmpsv, ",STRICT");
920 if (o->op_private & OPpCONST_ARYBASE)
921 sv_catpv(tmpsv, ",ARYBASE");
922 if (o->op_private & OPpCONST_WARNING)
923 sv_catpv(tmpsv, ",WARNING");
924 if (o->op_private & OPpCONST_ENTERED)
925 sv_catpv(tmpsv, ",ENTERED");
927 else if (optype == OP_FLIP) {
928 if (o->op_private & OPpFLIP_LINENUM)
929 sv_catpv(tmpsv, ",LINENUM");
931 else if (optype == OP_FLOP) {
932 if (o->op_private & OPpFLIP_LINENUM)
933 sv_catpv(tmpsv, ",LINENUM");
935 else if (optype == OP_RV2CV) {
936 if (o->op_private & OPpLVAL_INTRO)
937 sv_catpv(tmpsv, ",INTRO");
939 else if (optype == OP_GV) {
940 if (o->op_private & OPpEARLY_CV)
941 sv_catpv(tmpsv, ",EARLY_CV");
943 else if (optype == OP_LIST) {
944 if (o->op_private & OPpLIST_GUESSED)
945 sv_catpv(tmpsv, ",GUESSED");
947 else if (optype == OP_DELETE) {
948 if (o->op_private & OPpSLICE)
949 sv_catpv(tmpsv, ",SLICE");
951 else if (optype == OP_EXISTS) {
952 if (o->op_private & OPpEXISTS_SUB)
953 sv_catpv(tmpsv, ",EXISTS_SUB");
955 else if (optype == OP_SORT) {
956 if (o->op_private & OPpSORT_NUMERIC)
957 sv_catpv(tmpsv, ",NUMERIC");
958 if (o->op_private & OPpSORT_INTEGER)
959 sv_catpv(tmpsv, ",INTEGER");
960 if (o->op_private & OPpSORT_REVERSE)
961 sv_catpv(tmpsv, ",REVERSE");
963 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
964 if (o->op_private & OPpOPEN_IN_RAW)
965 sv_catpv(tmpsv, ",IN_RAW");
966 if (o->op_private & OPpOPEN_IN_CRLF)
967 sv_catpv(tmpsv, ",IN_CRLF");
968 if (o->op_private & OPpOPEN_OUT_RAW)
969 sv_catpv(tmpsv, ",OUT_RAW");
970 if (o->op_private & OPpOPEN_OUT_CRLF)
971 sv_catpv(tmpsv, ",OUT_CRLF");
973 else if (optype == OP_EXIT) {
974 if (o->op_private & OPpEXIT_VMSISH)
975 sv_catpv(tmpsv, ",EXIT_VMSISH");
976 if (o->op_private & OPpHUSH_VMSISH)
977 sv_catpv(tmpsv, ",HUSH_VMSISH");
979 else if (optype == OP_DIE) {
980 if (o->op_private & OPpHUSH_VMSISH)
981 sv_catpv(tmpsv, ",HUSH_VMSISH");
983 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
984 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
985 sv_catpv(tmpsv, ",FT_ACCESS");
986 if (o->op_private & OPpFT_STACKED)
987 sv_catpv(tmpsv, ",FT_STACKED");
989 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
990 sv_catpv(tmpsv, ",INTRO");
992 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
997 if (PL_madskills && o->op_madprop) {
998 SV * const tmpsv = newSVpvs("");
999 MADPROP* mp = o->op_madprop;
1000 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1003 const char tmp = mp->mad_key;
1004 sv_setpvs(tmpsv,"'");
1006 sv_catpvn(tmpsv, &tmp, 1);
1007 sv_catpv(tmpsv, "'=");
1008 switch (mp->mad_type) {
1010 sv_catpv(tmpsv, "NULL");
1011 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1014 sv_catpv(tmpsv, "<");
1015 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1016 sv_catpv(tmpsv, ">");
1017 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1020 if ((OP*)mp->mad_val) {
1021 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1022 do_op_dump(level, file, (OP*)mp->mad_val);
1026 sv_catpv(tmpsv, "(UNK)");
1027 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1033 Perl_dump_indent(aTHX_ level, file, "}\n");
1035 SvREFCNT_dec(tmpsv);
1044 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1046 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1047 if (cSVOPo->op_sv) {
1048 SV * const tmpsv = newSV(0);
1052 /* FIXME - is this making unwarranted assumptions about the
1053 UTF-8 cleanliness of the dump file handle? */
1056 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1057 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1058 SvPV_nolen_const(tmpsv));
1062 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1068 case OP_METHOD_NAMED:
1069 #ifndef USE_ITHREADS
1070 /* with ITHREADS, consts are stored in the pad, and the right pad
1071 * may not be active here, so skip */
1072 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1078 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1079 (UV)CopLINE(cCOPo));
1080 if (CopSTASHPV(cCOPo))
1081 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1083 if (CopLABEL(cCOPo))
1084 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1088 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1089 if (cLOOPo->op_redoop)
1090 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1092 PerlIO_printf(file, "DONE\n");
1093 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1094 if (cLOOPo->op_nextop)
1095 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1097 PerlIO_printf(file, "DONE\n");
1098 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1099 if (cLOOPo->op_lastop)
1100 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1102 PerlIO_printf(file, "DONE\n");
1110 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1111 if (cLOGOPo->op_other)
1112 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1114 PerlIO_printf(file, "DONE\n");
1120 do_pmop_dump(level, file, cPMOPo);
1128 if (o->op_private & OPpREFCOUNTED)
1129 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1134 if (o->op_flags & OPf_KIDS) {
1136 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1137 do_op_dump(level, file, kid);
1139 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1143 Perl_op_dump(pTHX_ const OP *o)
1145 PERL_ARGS_ASSERT_OP_DUMP;
1146 do_op_dump(0, Perl_debug_log, o);
1150 Perl_gv_dump(pTHX_ GV *gv)
1154 PERL_ARGS_ASSERT_GV_DUMP;
1157 PerlIO_printf(Perl_debug_log, "{}\n");
1160 sv = sv_newmortal();
1161 PerlIO_printf(Perl_debug_log, "{\n");
1162 gv_fullname3(sv, gv, NULL);
1163 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1164 if (gv != GvEGV(gv)) {
1165 gv_efullname3(sv, GvEGV(gv), NULL);
1166 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1168 PerlIO_putc(Perl_debug_log, '\n');
1169 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1173 /* map magic types to the symbolic names
1174 * (with the PERL_MAGIC_ prefixed stripped)
1177 static const struct { const char type; const char *name; } magic_names[] = {
1178 { PERL_MAGIC_sv, "sv(\\0)" },
1179 { PERL_MAGIC_arylen, "arylen(#)" },
1180 { PERL_MAGIC_rhash, "rhash(%)" },
1181 { PERL_MAGIC_pos, "pos(.)" },
1182 { PERL_MAGIC_symtab, "symtab(:)" },
1183 { PERL_MAGIC_backref, "backref(<)" },
1184 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1185 { PERL_MAGIC_overload, "overload(A)" },
1186 { PERL_MAGIC_bm, "bm(B)" },
1187 { PERL_MAGIC_regdata, "regdata(D)" },
1188 { PERL_MAGIC_env, "env(E)" },
1189 { PERL_MAGIC_hints, "hints(H)" },
1190 { PERL_MAGIC_isa, "isa(I)" },
1191 { PERL_MAGIC_dbfile, "dbfile(L)" },
1192 { PERL_MAGIC_shared, "shared(N)" },
1193 { PERL_MAGIC_tied, "tied(P)" },
1194 { PERL_MAGIC_sig, "sig(S)" },
1195 { PERL_MAGIC_uvar, "uvar(U)" },
1196 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1197 { PERL_MAGIC_overload_table, "overload_table(c)" },
1198 { PERL_MAGIC_regdatum, "regdatum(d)" },
1199 { PERL_MAGIC_envelem, "envelem(e)" },
1200 { PERL_MAGIC_fm, "fm(f)" },
1201 { PERL_MAGIC_regex_global, "regex_global(g)" },
1202 { PERL_MAGIC_hintselem, "hintselem(h)" },
1203 { PERL_MAGIC_isaelem, "isaelem(i)" },
1204 { PERL_MAGIC_nkeys, "nkeys(k)" },
1205 { PERL_MAGIC_dbline, "dbline(l)" },
1206 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1207 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1208 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1209 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1210 { PERL_MAGIC_qr, "qr(r)" },
1211 { PERL_MAGIC_sigelem, "sigelem(s)" },
1212 { PERL_MAGIC_taint, "taint(t)" },
1213 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1214 { PERL_MAGIC_vec, "vec(v)" },
1215 { PERL_MAGIC_vstring, "vstring(V)" },
1216 { PERL_MAGIC_utf8, "utf8(w)" },
1217 { PERL_MAGIC_substr, "substr(x)" },
1218 { PERL_MAGIC_defelem, "defelem(y)" },
1219 { PERL_MAGIC_ext, "ext(~)" },
1220 /* this null string terminates the list */
1225 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1227 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1229 for (; mg; mg = mg->mg_moremagic) {
1230 Perl_dump_indent(aTHX_ level, file,
1231 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1232 if (mg->mg_virtual) {
1233 const MGVTBL * const v = mg->mg_virtual;
1235 if (v == &PL_vtbl_sv) s = "sv";
1236 else if (v == &PL_vtbl_env) s = "env";
1237 else if (v == &PL_vtbl_envelem) s = "envelem";
1238 else if (v == &PL_vtbl_sig) s = "sig";
1239 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1240 else if (v == &PL_vtbl_pack) s = "pack";
1241 else if (v == &PL_vtbl_packelem) s = "packelem";
1242 else if (v == &PL_vtbl_dbline) s = "dbline";
1243 else if (v == &PL_vtbl_isa) s = "isa";
1244 else if (v == &PL_vtbl_arylen) s = "arylen";
1245 else if (v == &PL_vtbl_mglob) s = "mglob";
1246 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1247 else if (v == &PL_vtbl_taint) s = "taint";
1248 else if (v == &PL_vtbl_substr) s = "substr";
1249 else if (v == &PL_vtbl_vec) s = "vec";
1250 else if (v == &PL_vtbl_pos) s = "pos";
1251 else if (v == &PL_vtbl_bm) s = "bm";
1252 else if (v == &PL_vtbl_fm) s = "fm";
1253 else if (v == &PL_vtbl_uvar) s = "uvar";
1254 else if (v == &PL_vtbl_defelem) s = "defelem";
1255 #ifdef USE_LOCALE_COLLATE
1256 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1258 else if (v == &PL_vtbl_amagic) s = "amagic";
1259 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1260 else if (v == &PL_vtbl_backref) s = "backref";
1261 else if (v == &PL_vtbl_utf8) s = "utf8";
1262 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1263 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1264 else if (v == &PL_vtbl_hints) s = "hints";
1267 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1269 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1272 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1275 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1279 const char *name = NULL;
1280 for (n = 0; magic_names[n].name; n++) {
1281 if (mg->mg_type == magic_names[n].type) {
1282 name = magic_names[n].name;
1287 Perl_dump_indent(aTHX_ level, file,
1288 " MG_TYPE = PERL_MAGIC_%s\n", name);
1290 Perl_dump_indent(aTHX_ level, file,
1291 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1295 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1296 if (mg->mg_type == PERL_MAGIC_envelem &&
1297 mg->mg_flags & MGf_TAINTEDDIR)
1298 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1299 if (mg->mg_flags & MGf_REFCOUNTED)
1300 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1301 if (mg->mg_flags & MGf_GSKIP)
1302 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1303 if (mg->mg_type == PERL_MAGIC_regex_global &&
1304 mg->mg_flags & MGf_MINMATCH)
1305 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1308 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1309 PTR2UV(mg->mg_obj));
1310 if (mg->mg_type == PERL_MAGIC_qr) {
1311 REGEXP* const re = (REGEXP *)mg->mg_obj;
1312 SV * const dsv = sv_newmortal();
1313 const char * const s
1314 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1316 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1317 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1319 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1320 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1323 if (mg->mg_flags & MGf_REFCOUNTED)
1324 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1327 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1329 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1330 if (mg->mg_len >= 0) {
1331 if (mg->mg_type != PERL_MAGIC_utf8) {
1332 SV * const sv = newSVpvs("");
1333 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1337 else if (mg->mg_len == HEf_SVKEY) {
1338 PerlIO_puts(file, " => HEf_SVKEY\n");
1339 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1340 maxnest, dumpops, pvlim); /* MG is already +1 */
1344 PerlIO_puts(file, " ???? - please notify IZ");
1345 PerlIO_putc(file, '\n');
1347 if (mg->mg_type == PERL_MAGIC_utf8) {
1348 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1351 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1352 Perl_dump_indent(aTHX_ level, file,
1353 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1356 (UV)cache[i * 2 + 1]);
1363 Perl_magic_dump(pTHX_ const MAGIC *mg)
1365 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1369 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1373 PERL_ARGS_ASSERT_DO_HV_DUMP;
1375 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1376 if (sv && (hvname = HvNAME_get(sv)))
1377 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1379 PerlIO_putc(file, '\n');
1383 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1385 PERL_ARGS_ASSERT_DO_GV_DUMP;
1387 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1388 if (sv && GvNAME(sv))
1389 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1391 PerlIO_putc(file, '\n');
1395 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1397 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1399 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1400 if (sv && GvNAME(sv)) {
1402 PerlIO_printf(file, "\t\"");
1403 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1404 PerlIO_printf(file, "%s\" :: \"", hvname);
1405 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1408 PerlIO_putc(file, '\n');
1412 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1420 PERL_ARGS_ASSERT_DO_SV_DUMP;
1423 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1427 flags = SvFLAGS(sv);
1430 d = Perl_newSVpvf(aTHX_
1431 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1432 PTR2UV(SvANY(sv)), PTR2UV(sv),
1433 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1434 (int)(PL_dumpindent*level), "");
1436 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1437 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1439 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1440 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1441 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1443 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1444 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1445 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1446 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1447 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1449 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1450 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1451 if (flags & SVf_POK) sv_catpv(d, "POK,");
1452 if (flags & SVf_ROK) {
1453 sv_catpv(d, "ROK,");
1454 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1456 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1457 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1458 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1459 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1461 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1462 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1463 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1464 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1465 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1466 if (SvPCS_IMPORTED(sv))
1467 sv_catpv(d, "PCS_IMPORTED,");
1469 sv_catpv(d, "SCREAM,");
1475 if (CvANON(sv)) sv_catpv(d, "ANON,");
1476 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1477 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1478 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1479 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1480 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1481 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1482 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1483 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1484 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1487 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1488 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1489 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1490 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1491 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1495 if (isGV_with_GP(sv)) {
1496 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1497 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1498 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1499 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1501 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1502 sv_catpv(d, "IMPORT");
1503 if (GvIMPORTED(sv) == GVf_IMPORTED)
1504 sv_catpv(d, "ALL,");
1507 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1508 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1509 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1510 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1514 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1515 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1519 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1520 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1523 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1524 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1527 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1532 /* SVphv_SHAREKEYS is also 0x20000000 */
1533 if ((type != SVt_PVHV) && SvUTF8(sv))
1534 sv_catpv(d, "UTF8");
1536 if (*(SvEND(d) - 1) == ',') {
1537 SvCUR_set(d, SvCUR(d) - 1);
1538 SvPVX(d)[SvCUR(d)] = '\0';
1543 #ifdef DEBUG_LEAKING_SCALARS
1544 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1545 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1547 sv->sv_debug_inpad ? "for" : "by",
1548 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1549 sv->sv_debug_cloned ? " (cloned)" : "");
1551 Perl_dump_indent(aTHX_ level, file, "SV = ");
1552 if (type < SVt_LAST) {
1553 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1555 if (type == SVt_NULL) {
1560 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1564 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1565 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM)
1566 || (type == SVt_IV && !SvROK(sv))) {
1568 #ifdef PERL_OLD_COPY_ON_WRITE
1572 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1574 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1575 #ifdef PERL_OLD_COPY_ON_WRITE
1576 if (SvIsCOW_shared_hash(sv))
1577 PerlIO_printf(file, " (HASH)");
1578 else if (SvIsCOW_normal(sv))
1579 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1581 PerlIO_putc(file, '\n');
1583 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1584 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1585 (UV) COP_SEQ_RANGE_LOW(sv));
1586 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1587 (UV) COP_SEQ_RANGE_HIGH(sv));
1588 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1589 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1590 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1591 || type == SVt_NV) {
1592 STORE_NUMERIC_LOCAL_SET_STANDARD();
1593 /* %Vg doesn't work? --jhi */
1594 #ifdef USE_LONG_DOUBLE
1595 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1597 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1599 RESTORE_NUMERIC_LOCAL();
1602 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1604 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1606 if (type < SVt_PV) {
1610 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1611 if (SvPVX_const(sv)) {
1614 SvOOK_offset(sv, delta);
1615 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1620 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1622 PerlIO_printf(file, "( %s . ) ",
1623 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1626 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1627 if (SvUTF8(sv)) /* the 6? \x{....} */
1628 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1629 PerlIO_printf(file, "\n");
1630 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1631 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1634 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1636 if (type == SVt_REGEXP) {
1638 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1639 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1642 if (type >= SVt_PVMG) {
1643 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1644 HV * const ost = SvOURSTASH(sv);
1646 do_hv_dump(level, file, " OURSTASH", ost);
1649 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1652 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1656 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1657 if (AvARRAY(sv) != AvALLOC(sv)) {
1658 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1659 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1662 PerlIO_putc(file, '\n');
1663 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1664 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1665 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1667 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1668 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1669 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1670 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1671 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1673 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1674 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1676 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1678 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1683 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1684 if (HvARRAY(sv) && HvKEYS(sv)) {
1685 /* Show distribution of HEs in the ARRAY */
1687 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1690 U32 pow2 = 2, keys = HvKEYS(sv);
1691 NV theoret, sum = 0;
1693 PerlIO_printf(file, " (");
1694 Zero(freq, FREQ_MAX + 1, int);
1695 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1698 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1700 if (count > FREQ_MAX)
1706 for (i = 0; i <= max; i++) {
1708 PerlIO_printf(file, "%d%s:%d", i,
1709 (i == FREQ_MAX) ? "+" : "",
1712 PerlIO_printf(file, ", ");
1715 PerlIO_putc(file, ')');
1716 /* The "quality" of a hash is defined as the total number of
1717 comparisons needed to access every element once, relative
1718 to the expected number needed for a random hash.
1720 The total number of comparisons is equal to the sum of
1721 the squares of the number of entries in each bucket.
1722 For a random hash of n keys into k buckets, the expected
1727 for (i = max; i > 0; i--) { /* Precision: count down. */
1728 sum += freq[i] * i * i;
1730 while ((keys = keys >> 1))
1732 theoret = HvKEYS(sv);
1733 theoret += theoret * (theoret-1)/pow2;
1734 PerlIO_putc(file, '\n');
1735 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1737 PerlIO_putc(file, '\n');
1738 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1739 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1740 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1741 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1742 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1744 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1745 if (mg && mg->mg_obj) {
1746 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1750 const char * const hvname = HvNAME_get(sv);
1752 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1756 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1757 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1759 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1761 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1765 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1766 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1767 (int)meta->mro_which->length,
1768 meta->mro_which->name,
1769 PTR2UV(meta->mro_which));
1770 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1771 (UV)meta->cache_gen);
1772 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1774 if (meta->mro_linear_all) {
1775 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1776 PTR2UV(meta->mro_linear_all));
1777 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1780 if (meta->mro_linear_current) {
1781 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1782 PTR2UV(meta->mro_linear_current));
1783 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1786 if (meta->mro_nextmethod) {
1787 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1788 PTR2UV(meta->mro_nextmethod));
1789 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1793 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1795 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1800 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1802 HV * const hv = MUTABLE_HV(sv);
1803 int count = maxnest - nest;
1806 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1809 const U32 hash = HeHASH(he);
1810 SV * const keysv = hv_iterkeysv(he);
1811 const char * const keypv = SvPV_const(keysv, len);
1812 SV * const elt = hv_iterval(hv, he);
1814 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1816 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1818 PerlIO_printf(file, "[REHASH] ");
1819 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1820 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1822 hv_iterinit(hv); /* Return to status quo */
1828 const char *const proto = SvPV_const(sv, len);
1829 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1834 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1835 if (!CvISXSUB(sv)) {
1837 Perl_dump_indent(aTHX_ level, file,
1838 " START = 0x%"UVxf" ===> %"IVdf"\n",
1839 PTR2UV(CvSTART(sv)),
1840 (IV)sequence_num(CvSTART(sv)));
1842 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1843 PTR2UV(CvROOT(sv)));
1844 if (CvROOT(sv) && dumpops) {
1845 do_op_dump(level+1, file, CvROOT(sv));
1848 SV * const constant = cv_const_sv((const CV *)sv);
1850 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1853 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1855 PTR2UV(CvXSUBANY(sv).any_ptr));
1856 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1859 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1860 (IV)CvXSUBANY(sv).any_i32);
1863 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1864 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1865 if (type == SVt_PVCV)
1866 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1867 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1868 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1869 if (type == SVt_PVFM)
1870 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1871 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1872 if (nest < maxnest) {
1873 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1876 const CV * const outside = CvOUTSIDE(sv);
1877 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1880 : CvANON(outside) ? "ANON"
1881 : (outside == PL_main_cv) ? "MAIN"
1882 : CvUNIQUE(outside) ? "UNIQUE"
1883 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1885 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1886 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1890 if (type == SVt_PVLV) {
1891 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1892 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1893 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1894 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1895 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1896 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1900 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1901 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1902 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1903 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1905 if (!isGV_with_GP(sv))
1907 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1908 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1909 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1910 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1913 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1914 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1915 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1916 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1917 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1918 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1919 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1920 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1921 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1922 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1923 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1924 do_gv_dump (level, file, " EGV", GvEGV(sv));
1927 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1928 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1929 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1930 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1931 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1932 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1933 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1935 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1936 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1937 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1939 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1940 PTR2UV(IoTOP_GV(sv)));
1941 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1942 maxnest, dumpops, pvlim);
1944 /* Source filters hide things that are not GVs in these three, so let's
1945 be careful out there. */
1947 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1948 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1949 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1951 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1952 PTR2UV(IoFMT_GV(sv)));
1953 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1954 maxnest, dumpops, pvlim);
1956 if (IoBOTTOM_NAME(sv))
1957 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1958 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1959 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1961 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1962 PTR2UV(IoBOTTOM_GV(sv)));
1963 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
1964 maxnest, dumpops, pvlim);
1966 if (isPRINT(IoTYPE(sv)))
1967 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1969 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1970 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1977 Perl_sv_dump(pTHX_ SV *sv)
1981 PERL_ARGS_ASSERT_SV_DUMP;
1984 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1986 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1990 Perl_runops_debug(pTHX)
1994 if (ckWARN_d(WARN_DEBUGGING))
1995 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1999 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2003 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2004 PerlIO_printf(Perl_debug_log,
2005 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2006 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2007 PTR2UV(*PL_watchaddr));
2008 if (DEBUG_s_TEST_) {
2009 if (DEBUG_v_TEST_) {
2010 PerlIO_printf(Perl_debug_log, "\n");
2018 if (DEBUG_t_TEST_) debop(PL_op);
2019 if (DEBUG_P_TEST_) debprof(PL_op);
2021 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2022 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2029 Perl_debop(pTHX_ const OP *o)
2033 PERL_ARGS_ASSERT_DEBOP;
2035 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2038 Perl_deb(aTHX_ "%s", OP_NAME(o));
2039 switch (o->op_type) {
2042 /* With ITHREADS, consts are stored in the pad, and the right pad
2043 * may not be active here, so check.
2044 * Looks like only during compiling the pads are illegal.
2047 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2049 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2054 SV * const sv = newSV(0);
2056 /* FIXME - is this making unwarranted assumptions about the
2057 UTF-8 cleanliness of the dump file handle? */
2060 gv_fullname3(sv, cGVOPo_gv, NULL);
2061 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2065 PerlIO_printf(Perl_debug_log, "(NULL)");
2071 /* print the lexical's name */
2072 CV * const cv = deb_curcv(cxstack_ix);
2075 AV * const padlist = CvPADLIST(cv);
2076 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2077 sv = *av_fetch(comppad, o->op_targ, FALSE);
2081 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2083 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2089 PerlIO_printf(Perl_debug_log, "\n");
2094 S_deb_curcv(pTHX_ const I32 ix)
2097 const PERL_CONTEXT * const cx = &cxstack[ix];
2098 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2099 return cx->blk_sub.cv;
2100 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2102 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2107 return deb_curcv(ix - 1);
2111 Perl_watch(pTHX_ char **addr)
2115 PERL_ARGS_ASSERT_WATCH;
2117 PL_watchaddr = addr;
2119 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2120 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2124 S_debprof(pTHX_ const OP *o)
2128 PERL_ARGS_ASSERT_DEBPROF;
2130 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2132 if (!PL_profiledata)
2133 Newxz(PL_profiledata, MAXO, U32);
2134 ++PL_profiledata[o->op_type];
2138 Perl_debprofdump(pTHX)
2142 if (!PL_profiledata)
2144 for (i = 0; i < MAXO; i++) {
2145 if (PL_profiledata[i])
2146 PerlIO_printf(Perl_debug_log,
2147 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2154 * XML variants of most of the above routines
2158 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2162 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2164 PerlIO_printf(file, "\n ");
2165 va_start(args, pat);
2166 xmldump_vindent(level, file, pat, &args);
2172 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2175 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2176 va_start(args, pat);
2177 xmldump_vindent(level, file, pat, &args);
2182 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2184 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2186 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2187 PerlIO_vprintf(file, pat, *args);
2191 Perl_xmldump_all(pTHX)
2193 PerlIO_setlinebuf(PL_xmlfp);
2195 op_xmldump(PL_main_root);
2196 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2197 PerlIO_close(PL_xmlfp);
2202 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2207 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2209 if (!HvARRAY(stash))
2211 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2212 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2213 GV *gv = MUTABLE_GV(HeVAL(entry));
2215 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2221 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2222 && (hv = GvHV(gv)) && hv != PL_defstash)
2223 xmldump_packsubs(hv); /* nested package */
2229 Perl_xmldump_sub(pTHX_ const GV *gv)
2231 SV * const sv = sv_newmortal();
2233 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2235 gv_fullname3(sv, gv, NULL);
2236 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2237 if (CvXSUB(GvCV(gv)))
2238 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2239 PTR2UV(CvXSUB(GvCV(gv))),
2240 (int)CvXSUBANY(GvCV(gv)).any_i32);
2241 else if (CvROOT(GvCV(gv)))
2242 op_xmldump(CvROOT(GvCV(gv)));
2244 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2248 Perl_xmldump_form(pTHX_ const GV *gv)
2250 SV * const sv = sv_newmortal();
2252 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2254 gv_fullname3(sv, gv, NULL);
2255 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2256 if (CvROOT(GvFORM(gv)))
2257 op_xmldump(CvROOT(GvFORM(gv)));
2259 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2263 Perl_xmldump_eval(pTHX)
2265 op_xmldump(PL_eval_root);
2269 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2271 PERL_ARGS_ASSERT_SV_CATXMLSV;
2272 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2276 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2279 const char * const e = pv + len;
2280 const char * const start = pv;
2284 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2287 dsvcur = SvCUR(dsv); /* in case we have to restart */
2292 c = utf8_to_uvchr((U8*)pv, &cl);
2294 SvCUR(dsv) = dsvcur;
2359 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2362 sv_catpvs(dsv, "<");
2365 sv_catpvs(dsv, ">");
2368 sv_catpvs(dsv, "&");
2371 sv_catpvs(dsv, """);
2375 if (c < 32 || c > 127) {
2376 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2379 const char string = (char) c;
2380 sv_catpvn(dsv, &string, 1);
2384 if ((c >= 0xD800 && c <= 0xDB7F) ||
2385 (c >= 0xDC00 && c <= 0xDFFF) ||
2386 (c >= 0xFFF0 && c <= 0xFFFF) ||
2388 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2390 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2403 Perl_sv_xmlpeek(pTHX_ SV *sv)
2405 SV * const t = sv_newmortal();
2409 PERL_ARGS_ASSERT_SV_XMLPEEK;
2415 sv_catpv(t, "VOID=\"\"");
2418 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2419 sv_catpv(t, "WILD=\"\"");
2422 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2423 if (sv == &PL_sv_undef) {
2424 sv_catpv(t, "SV_UNDEF=\"1\"");
2425 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2426 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2430 else if (sv == &PL_sv_no) {
2431 sv_catpv(t, "SV_NO=\"1\"");
2432 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2433 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2434 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2435 SVp_POK|SVp_NOK)) &&
2440 else if (sv == &PL_sv_yes) {
2441 sv_catpv(t, "SV_YES=\"1\"");
2442 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2443 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2444 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2445 SVp_POK|SVp_NOK)) &&
2447 SvPVX(sv) && *SvPVX(sv) == '1' &&
2452 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2453 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2454 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2458 sv_catpv(t, " XXX=\"\" ");
2460 else if (SvREFCNT(sv) == 0) {
2461 sv_catpv(t, " refcnt=\"0\"");
2464 else if (DEBUG_R_TEST_) {
2467 /* is this SV on the tmps stack? */
2468 for (ix=PL_tmps_ix; ix>=0; ix--) {
2469 if (PL_tmps_stack[ix] == sv) {
2474 if (SvREFCNT(sv) > 1)
2475 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2478 sv_catpv(t, " DRT=\"<T>\"");
2482 sv_catpv(t, " ROK=\"\"");
2484 switch (SvTYPE(sv)) {
2486 sv_catpv(t, " FREED=\"1\"");
2490 sv_catpv(t, " UNDEF=\"1\"");
2493 sv_catpv(t, " IV=\"");
2496 sv_catpv(t, " NV=\"");
2499 sv_catpv(t, " PV=\"");
2502 sv_catpv(t, " PVIV=\"");
2505 sv_catpv(t, " PVNV=\"");
2508 sv_catpv(t, " PVMG=\"");
2511 sv_catpv(t, " PVLV=\"");
2514 sv_catpv(t, " AV=\"");
2517 sv_catpv(t, " HV=\"");
2521 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2523 sv_catpv(t, " CV=\"()\"");
2526 sv_catpv(t, " GV=\"");
2529 sv_catpv(t, " BIND=\"");
2532 sv_catpv(t, " ORANGE=\"");
2535 sv_catpv(t, " FM=\"");
2538 sv_catpv(t, " IO=\"");
2547 else if (SvNOKp(sv)) {
2548 STORE_NUMERIC_LOCAL_SET_STANDARD();
2549 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2550 RESTORE_NUMERIC_LOCAL();
2552 else if (SvIOKp(sv)) {
2554 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2556 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2565 return SvPV(t, n_a);
2569 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2571 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2574 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2577 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2580 REGEXP *const r = PM_GETRE(pm);
2581 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2582 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2583 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2585 SvREFCNT_dec(tmpsv);
2586 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2587 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2590 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2591 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2592 SV * const tmpsv = pm_description(pm);
2593 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2594 SvREFCNT_dec(tmpsv);
2598 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2599 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2600 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2601 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2602 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2603 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2606 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2610 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2612 do_pmop_xmldump(0, PL_xmlfp, pm);
2616 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2621 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2626 seq = sequence_num(o);
2627 Perl_xmldump_indent(aTHX_ level, file,
2628 "<op_%s seq=\"%"UVuf" -> ",
2633 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2634 sequence_num(o->op_next));
2636 PerlIO_printf(file, "DONE\"");
2639 if (o->op_type == OP_NULL)
2641 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2642 if (o->op_targ == OP_NEXTSTATE)
2645 PerlIO_printf(file, " line=\"%"UVuf"\"",
2646 (UV)CopLINE(cCOPo));
2647 if (CopSTASHPV(cCOPo))
2648 PerlIO_printf(file, " package=\"%s\"",
2650 if (CopLABEL(cCOPo))
2651 PerlIO_printf(file, " label=\"%s\"",
2656 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2659 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2662 SV * const tmpsv = newSVpvs("");
2663 switch (o->op_flags & OPf_WANT) {
2665 sv_catpv(tmpsv, ",VOID");
2667 case OPf_WANT_SCALAR:
2668 sv_catpv(tmpsv, ",SCALAR");
2671 sv_catpv(tmpsv, ",LIST");
2674 sv_catpv(tmpsv, ",UNKNOWN");
2677 if (o->op_flags & OPf_KIDS)
2678 sv_catpv(tmpsv, ",KIDS");
2679 if (o->op_flags & OPf_PARENS)
2680 sv_catpv(tmpsv, ",PARENS");
2681 if (o->op_flags & OPf_STACKED)
2682 sv_catpv(tmpsv, ",STACKED");
2683 if (o->op_flags & OPf_REF)
2684 sv_catpv(tmpsv, ",REF");
2685 if (o->op_flags & OPf_MOD)
2686 sv_catpv(tmpsv, ",MOD");
2687 if (o->op_flags & OPf_SPECIAL)
2688 sv_catpv(tmpsv, ",SPECIAL");
2689 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2690 SvREFCNT_dec(tmpsv);
2692 if (o->op_private) {
2693 SV * const tmpsv = newSVpvs("");
2694 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2695 if (o->op_private & OPpTARGET_MY)
2696 sv_catpv(tmpsv, ",TARGET_MY");
2698 else if (o->op_type == OP_LEAVESUB ||
2699 o->op_type == OP_LEAVE ||
2700 o->op_type == OP_LEAVESUBLV ||
2701 o->op_type == OP_LEAVEWRITE) {
2702 if (o->op_private & OPpREFCOUNTED)
2703 sv_catpv(tmpsv, ",REFCOUNTED");
2705 else if (o->op_type == OP_AASSIGN) {
2706 if (o->op_private & OPpASSIGN_COMMON)
2707 sv_catpv(tmpsv, ",COMMON");
2709 else if (o->op_type == OP_SASSIGN) {
2710 if (o->op_private & OPpASSIGN_BACKWARDS)
2711 sv_catpv(tmpsv, ",BACKWARDS");
2713 else if (o->op_type == OP_TRANS) {
2714 if (o->op_private & OPpTRANS_SQUASH)
2715 sv_catpv(tmpsv, ",SQUASH");
2716 if (o->op_private & OPpTRANS_DELETE)
2717 sv_catpv(tmpsv, ",DELETE");
2718 if (o->op_private & OPpTRANS_COMPLEMENT)
2719 sv_catpv(tmpsv, ",COMPLEMENT");
2720 if (o->op_private & OPpTRANS_IDENTICAL)
2721 sv_catpv(tmpsv, ",IDENTICAL");
2722 if (o->op_private & OPpTRANS_GROWS)
2723 sv_catpv(tmpsv, ",GROWS");
2725 else if (o->op_type == OP_REPEAT) {
2726 if (o->op_private & OPpREPEAT_DOLIST)
2727 sv_catpv(tmpsv, ",DOLIST");
2729 else if (o->op_type == OP_ENTERSUB ||
2730 o->op_type == OP_RV2SV ||
2731 o->op_type == OP_GVSV ||
2732 o->op_type == OP_RV2AV ||
2733 o->op_type == OP_RV2HV ||
2734 o->op_type == OP_RV2GV ||
2735 o->op_type == OP_AELEM ||
2736 o->op_type == OP_HELEM )
2738 if (o->op_type == OP_ENTERSUB) {
2739 if (o->op_private & OPpENTERSUB_AMPER)
2740 sv_catpv(tmpsv, ",AMPER");
2741 if (o->op_private & OPpENTERSUB_DB)
2742 sv_catpv(tmpsv, ",DB");
2743 if (o->op_private & OPpENTERSUB_HASTARG)
2744 sv_catpv(tmpsv, ",HASTARG");
2745 if (o->op_private & OPpENTERSUB_NOPAREN)
2746 sv_catpv(tmpsv, ",NOPAREN");
2747 if (o->op_private & OPpENTERSUB_INARGS)
2748 sv_catpv(tmpsv, ",INARGS");
2749 if (o->op_private & OPpENTERSUB_NOMOD)
2750 sv_catpv(tmpsv, ",NOMOD");
2753 switch (o->op_private & OPpDEREF) {
2755 sv_catpv(tmpsv, ",SV");
2758 sv_catpv(tmpsv, ",AV");
2761 sv_catpv(tmpsv, ",HV");
2764 if (o->op_private & OPpMAYBE_LVSUB)
2765 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2767 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2768 if (o->op_private & OPpLVAL_DEFER)
2769 sv_catpv(tmpsv, ",LVAL_DEFER");
2772 if (o->op_private & HINT_STRICT_REFS)
2773 sv_catpv(tmpsv, ",STRICT_REFS");
2774 if (o->op_private & OPpOUR_INTRO)
2775 sv_catpv(tmpsv, ",OUR_INTRO");
2778 else if (o->op_type == OP_CONST) {
2779 if (o->op_private & OPpCONST_BARE)
2780 sv_catpv(tmpsv, ",BARE");
2781 if (o->op_private & OPpCONST_STRICT)
2782 sv_catpv(tmpsv, ",STRICT");
2783 if (o->op_private & OPpCONST_ARYBASE)
2784 sv_catpv(tmpsv, ",ARYBASE");
2785 if (o->op_private & OPpCONST_WARNING)
2786 sv_catpv(tmpsv, ",WARNING");
2787 if (o->op_private & OPpCONST_ENTERED)
2788 sv_catpv(tmpsv, ",ENTERED");
2790 else if (o->op_type == OP_FLIP) {
2791 if (o->op_private & OPpFLIP_LINENUM)
2792 sv_catpv(tmpsv, ",LINENUM");
2794 else if (o->op_type == OP_FLOP) {
2795 if (o->op_private & OPpFLIP_LINENUM)
2796 sv_catpv(tmpsv, ",LINENUM");
2798 else if (o->op_type == OP_RV2CV) {
2799 if (o->op_private & OPpLVAL_INTRO)
2800 sv_catpv(tmpsv, ",INTRO");
2802 else if (o->op_type == OP_GV) {
2803 if (o->op_private & OPpEARLY_CV)
2804 sv_catpv(tmpsv, ",EARLY_CV");
2806 else if (o->op_type == OP_LIST) {
2807 if (o->op_private & OPpLIST_GUESSED)
2808 sv_catpv(tmpsv, ",GUESSED");
2810 else if (o->op_type == OP_DELETE) {
2811 if (o->op_private & OPpSLICE)
2812 sv_catpv(tmpsv, ",SLICE");
2814 else if (o->op_type == OP_EXISTS) {
2815 if (o->op_private & OPpEXISTS_SUB)
2816 sv_catpv(tmpsv, ",EXISTS_SUB");
2818 else if (o->op_type == OP_SORT) {
2819 if (o->op_private & OPpSORT_NUMERIC)
2820 sv_catpv(tmpsv, ",NUMERIC");
2821 if (o->op_private & OPpSORT_INTEGER)
2822 sv_catpv(tmpsv, ",INTEGER");
2823 if (o->op_private & OPpSORT_REVERSE)
2824 sv_catpv(tmpsv, ",REVERSE");
2826 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2827 if (o->op_private & OPpOPEN_IN_RAW)
2828 sv_catpv(tmpsv, ",IN_RAW");
2829 if (o->op_private & OPpOPEN_IN_CRLF)
2830 sv_catpv(tmpsv, ",IN_CRLF");
2831 if (o->op_private & OPpOPEN_OUT_RAW)
2832 sv_catpv(tmpsv, ",OUT_RAW");
2833 if (o->op_private & OPpOPEN_OUT_CRLF)
2834 sv_catpv(tmpsv, ",OUT_CRLF");
2836 else if (o->op_type == OP_EXIT) {
2837 if (o->op_private & OPpEXIT_VMSISH)
2838 sv_catpv(tmpsv, ",EXIT_VMSISH");
2839 if (o->op_private & OPpHUSH_VMSISH)
2840 sv_catpv(tmpsv, ",HUSH_VMSISH");
2842 else if (o->op_type == OP_DIE) {
2843 if (o->op_private & OPpHUSH_VMSISH)
2844 sv_catpv(tmpsv, ",HUSH_VMSISH");
2846 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2847 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2848 sv_catpv(tmpsv, ",FT_ACCESS");
2849 if (o->op_private & OPpFT_STACKED)
2850 sv_catpv(tmpsv, ",FT_STACKED");
2852 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2853 sv_catpv(tmpsv, ",INTRO");
2855 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2856 SvREFCNT_dec(tmpsv);
2859 switch (o->op_type) {
2861 if (o->op_flags & OPf_SPECIAL) {
2867 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2869 if (cSVOPo->op_sv) {
2870 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2871 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2877 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2878 s = SvPV(tmpsv1,len);
2879 sv_catxmlpvn(tmpsv2, s, len, 1);
2880 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2884 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2889 case OP_METHOD_NAMED:
2890 #ifndef USE_ITHREADS
2891 /* with ITHREADS, consts are stored in the pad, and the right pad
2892 * may not be active here, so skip */
2893 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2899 PerlIO_printf(file, ">\n");
2901 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2906 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2907 (UV)CopLINE(cCOPo));
2908 if (CopSTASHPV(cCOPo))
2909 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2911 if (CopLABEL(cCOPo))
2912 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2916 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2917 if (cLOOPo->op_redoop)
2918 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2920 PerlIO_printf(file, "DONE\"");
2921 S_xmldump_attr(aTHX_ level, file, "next=\"");
2922 if (cLOOPo->op_nextop)
2923 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2925 PerlIO_printf(file, "DONE\"");
2926 S_xmldump_attr(aTHX_ level, file, "last=\"");
2927 if (cLOOPo->op_lastop)
2928 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2930 PerlIO_printf(file, "DONE\"");
2938 S_xmldump_attr(aTHX_ level, file, "other=\"");
2939 if (cLOGOPo->op_other)
2940 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2942 PerlIO_printf(file, "DONE\"");
2950 if (o->op_private & OPpREFCOUNTED)
2951 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2957 if (PL_madskills && o->op_madprop) {
2958 char prevkey = '\0';
2959 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2960 const MADPROP* mp = o->op_madprop;
2964 PerlIO_printf(file, ">\n");
2966 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2969 char tmp = mp->mad_key;
2970 sv_setpvs(tmpsv,"\"");
2972 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2973 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2974 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2977 sv_catpv(tmpsv, "\"");
2978 switch (mp->mad_type) {
2980 sv_catpv(tmpsv, "NULL");
2981 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2984 sv_catpv(tmpsv, " val=\"");
2985 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2986 sv_catpv(tmpsv, "\"");
2987 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2990 sv_catpv(tmpsv, " val=\"");
2991 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
2992 sv_catpv(tmpsv, "\"");
2993 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2996 if ((OP*)mp->mad_val) {
2997 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2998 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2999 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3003 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3009 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3011 SvREFCNT_dec(tmpsv);
3014 switch (o->op_type) {
3021 PerlIO_printf(file, ">\n");
3023 do_pmop_xmldump(level, file, cPMOPo);
3029 if (o->op_flags & OPf_KIDS) {
3033 PerlIO_printf(file, ">\n");
3035 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3036 do_op_xmldump(level, file, kid);
3040 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3042 PerlIO_printf(file, " />\n");
3046 Perl_op_xmldump(pTHX_ const OP *o)
3048 PERL_ARGS_ASSERT_OP_XMLDUMP;
3050 do_op_xmldump(0, PL_xmlfp, o);
3056 * c-indentation-style: bsd
3058 * indent-tabs-mode: t
3061 * ex: set ts=8 sts=4 sw=4 noet: