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("");
509 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
510 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
512 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
513 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
518 else if (SvNOKp(sv)) {
519 STORE_NUMERIC_LOCAL_SET_STANDARD();
520 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
521 RESTORE_NUMERIC_LOCAL();
523 else if (SvIOKp(sv)) {
525 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
527 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
535 if (PL_tainting && SvTAINTED(sv))
536 sv_catpv(t, " [tainted]");
537 return SvPV_nolen(t);
541 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
545 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
548 Perl_dump_indent(aTHX_ level, file, "{}\n");
551 Perl_dump_indent(aTHX_ level, file, "{\n");
553 if (pm->op_pmflags & PMf_ONCE)
558 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
559 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
560 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
562 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
563 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
564 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
565 op_dump(pm->op_pmreplrootu.op_pmreplroot);
567 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
568 SV * const tmpsv = pm_description(pm);
569 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
573 Perl_dump_indent(aTHX_ level-1, file, "}\n");
577 S_pm_description(pTHX_ const PMOP *pm)
579 SV * const desc = newSVpvs("");
580 const REGEXP * const regex = PM_GETRE(pm);
581 const U32 pmflags = pm->op_pmflags;
583 PERL_ARGS_ASSERT_PM_DESCRIPTION;
585 if (pmflags & PMf_ONCE)
586 sv_catpv(desc, ",ONCE");
588 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
589 sv_catpv(desc, ":USED");
591 if (pmflags & PMf_USED)
592 sv_catpv(desc, ":USED");
596 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
597 sv_catpv(desc, ",TAINTED");
598 if (RX_CHECK_SUBSTR(regex)) {
599 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
600 sv_catpv(desc, ",SCANFIRST");
601 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
602 sv_catpv(desc, ",ALL");
604 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
605 sv_catpv(desc, ",SKIPWHITE");
608 if (pmflags & PMf_CONST)
609 sv_catpv(desc, ",CONST");
610 if (pmflags & PMf_KEEP)
611 sv_catpv(desc, ",KEEP");
612 if (pmflags & PMf_GLOBAL)
613 sv_catpv(desc, ",GLOBAL");
614 if (pmflags & PMf_CONTINUE)
615 sv_catpv(desc, ",CONTINUE");
616 if (pmflags & PMf_RETAINT)
617 sv_catpv(desc, ",RETAINT");
618 if (pmflags & PMf_EVAL)
619 sv_catpv(desc, ",EVAL");
624 Perl_pmop_dump(pTHX_ PMOP *pm)
626 do_pmop_dump(0, Perl_debug_log, pm);
629 /* An op sequencer. We visit the ops in the order they're to execute. */
632 S_sequence(pTHX_ register const OP *o)
635 const OP *oldop = NULL;
648 for (; o; o = o->op_next) {
650 SV * const op = newSVuv(PTR2UV(o));
651 const char * const key = SvPV_const(op, len);
653 if (hv_exists(Sequence, key, len))
656 switch (o->op_type) {
658 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
659 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
668 if (oldop && o->op_next)
675 if (oldop && o->op_next)
677 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
690 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
691 sequence_tail(cLOGOPo->op_other);
696 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
697 sequence_tail(cLOOPo->op_redoop);
698 sequence_tail(cLOOPo->op_nextop);
699 sequence_tail(cLOOPo->op_lastop);
703 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
704 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
713 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
721 S_sequence_tail(pTHX_ const OP *o)
723 while (o && (o->op_type == OP_NULL))
729 S_sequence_num(pTHX_ const OP *o)
737 op = newSVuv(PTR2UV(o));
738 key = SvPV_const(op, len);
739 seq = hv_fetch(Sequence, key, len, 0);
740 return seq ? SvUV(*seq): 0;
744 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
748 const OPCODE optype = o->op_type;
750 PERL_ARGS_ASSERT_DO_OP_DUMP;
753 Perl_dump_indent(aTHX_ level, file, "{\n");
755 seq = sequence_num(o);
757 PerlIO_printf(file, "%-4"UVuf, seq);
759 PerlIO_printf(file, " ");
761 "%*sTYPE = %s ===> ",
762 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
764 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
765 sequence_num(o->op_next));
767 PerlIO_printf(file, "DONE\n");
769 if (optype == OP_NULL) {
770 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
771 if (o->op_targ == OP_NEXTSTATE) {
773 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
775 if (CopSTASHPV(cCOPo))
776 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
779 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
784 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
787 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
789 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
790 SV * const tmpsv = newSVpvs("");
791 switch (o->op_flags & OPf_WANT) {
793 sv_catpv(tmpsv, ",VOID");
795 case OPf_WANT_SCALAR:
796 sv_catpv(tmpsv, ",SCALAR");
799 sv_catpv(tmpsv, ",LIST");
802 sv_catpv(tmpsv, ",UNKNOWN");
805 if (o->op_flags & OPf_KIDS)
806 sv_catpv(tmpsv, ",KIDS");
807 if (o->op_flags & OPf_PARENS)
808 sv_catpv(tmpsv, ",PARENS");
809 if (o->op_flags & OPf_STACKED)
810 sv_catpv(tmpsv, ",STACKED");
811 if (o->op_flags & OPf_REF)
812 sv_catpv(tmpsv, ",REF");
813 if (o->op_flags & OPf_MOD)
814 sv_catpv(tmpsv, ",MOD");
815 if (o->op_flags & OPf_SPECIAL)
816 sv_catpv(tmpsv, ",SPECIAL");
818 sv_catpv(tmpsv, ",LATEFREE");
820 sv_catpv(tmpsv, ",LATEFREED");
822 sv_catpv(tmpsv, ",ATTACHED");
823 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
827 SV * const tmpsv = newSVpvs("");
828 if (PL_opargs[optype] & OA_TARGLEX) {
829 if (o->op_private & OPpTARGET_MY)
830 sv_catpv(tmpsv, ",TARGET_MY");
832 else if (optype == OP_LEAVESUB ||
833 optype == OP_LEAVE ||
834 optype == OP_LEAVESUBLV ||
835 optype == OP_LEAVEWRITE) {
836 if (o->op_private & OPpREFCOUNTED)
837 sv_catpv(tmpsv, ",REFCOUNTED");
839 else if (optype == OP_AASSIGN) {
840 if (o->op_private & OPpASSIGN_COMMON)
841 sv_catpv(tmpsv, ",COMMON");
843 else if (optype == OP_SASSIGN) {
844 if (o->op_private & OPpASSIGN_BACKWARDS)
845 sv_catpv(tmpsv, ",BACKWARDS");
847 else if (optype == OP_TRANS) {
848 if (o->op_private & OPpTRANS_SQUASH)
849 sv_catpv(tmpsv, ",SQUASH");
850 if (o->op_private & OPpTRANS_DELETE)
851 sv_catpv(tmpsv, ",DELETE");
852 if (o->op_private & OPpTRANS_COMPLEMENT)
853 sv_catpv(tmpsv, ",COMPLEMENT");
854 if (o->op_private & OPpTRANS_IDENTICAL)
855 sv_catpv(tmpsv, ",IDENTICAL");
856 if (o->op_private & OPpTRANS_GROWS)
857 sv_catpv(tmpsv, ",GROWS");
859 else if (optype == OP_REPEAT) {
860 if (o->op_private & OPpREPEAT_DOLIST)
861 sv_catpv(tmpsv, ",DOLIST");
863 else if (optype == OP_ENTERSUB ||
864 optype == OP_RV2SV ||
866 optype == OP_RV2AV ||
867 optype == OP_RV2HV ||
868 optype == OP_RV2GV ||
869 optype == OP_AELEM ||
872 if (optype == OP_ENTERSUB) {
873 if (o->op_private & OPpENTERSUB_AMPER)
874 sv_catpv(tmpsv, ",AMPER");
875 if (o->op_private & OPpENTERSUB_DB)
876 sv_catpv(tmpsv, ",DB");
877 if (o->op_private & OPpENTERSUB_HASTARG)
878 sv_catpv(tmpsv, ",HASTARG");
879 if (o->op_private & OPpENTERSUB_NOPAREN)
880 sv_catpv(tmpsv, ",NOPAREN");
881 if (o->op_private & OPpENTERSUB_INARGS)
882 sv_catpv(tmpsv, ",INARGS");
883 if (o->op_private & OPpENTERSUB_NOMOD)
884 sv_catpv(tmpsv, ",NOMOD");
887 switch (o->op_private & OPpDEREF) {
889 sv_catpv(tmpsv, ",SV");
892 sv_catpv(tmpsv, ",AV");
895 sv_catpv(tmpsv, ",HV");
898 if (o->op_private & OPpMAYBE_LVSUB)
899 sv_catpv(tmpsv, ",MAYBE_LVSUB");
901 if (optype == OP_AELEM || optype == OP_HELEM) {
902 if (o->op_private & OPpLVAL_DEFER)
903 sv_catpv(tmpsv, ",LVAL_DEFER");
906 if (o->op_private & HINT_STRICT_REFS)
907 sv_catpv(tmpsv, ",STRICT_REFS");
908 if (o->op_private & OPpOUR_INTRO)
909 sv_catpv(tmpsv, ",OUR_INTRO");
912 else if (optype == OP_CONST) {
913 if (o->op_private & OPpCONST_BARE)
914 sv_catpv(tmpsv, ",BARE");
915 if (o->op_private & OPpCONST_STRICT)
916 sv_catpv(tmpsv, ",STRICT");
917 if (o->op_private & OPpCONST_ARYBASE)
918 sv_catpv(tmpsv, ",ARYBASE");
919 if (o->op_private & OPpCONST_WARNING)
920 sv_catpv(tmpsv, ",WARNING");
921 if (o->op_private & OPpCONST_ENTERED)
922 sv_catpv(tmpsv, ",ENTERED");
924 else if (optype == OP_FLIP) {
925 if (o->op_private & OPpFLIP_LINENUM)
926 sv_catpv(tmpsv, ",LINENUM");
928 else if (optype == OP_FLOP) {
929 if (o->op_private & OPpFLIP_LINENUM)
930 sv_catpv(tmpsv, ",LINENUM");
932 else if (optype == OP_RV2CV) {
933 if (o->op_private & OPpLVAL_INTRO)
934 sv_catpv(tmpsv, ",INTRO");
936 else if (optype == OP_GV) {
937 if (o->op_private & OPpEARLY_CV)
938 sv_catpv(tmpsv, ",EARLY_CV");
940 else if (optype == OP_LIST) {
941 if (o->op_private & OPpLIST_GUESSED)
942 sv_catpv(tmpsv, ",GUESSED");
944 else if (optype == OP_DELETE) {
945 if (o->op_private & OPpSLICE)
946 sv_catpv(tmpsv, ",SLICE");
948 else if (optype == OP_EXISTS) {
949 if (o->op_private & OPpEXISTS_SUB)
950 sv_catpv(tmpsv, ",EXISTS_SUB");
952 else if (optype == OP_SORT) {
953 if (o->op_private & OPpSORT_NUMERIC)
954 sv_catpv(tmpsv, ",NUMERIC");
955 if (o->op_private & OPpSORT_INTEGER)
956 sv_catpv(tmpsv, ",INTEGER");
957 if (o->op_private & OPpSORT_REVERSE)
958 sv_catpv(tmpsv, ",REVERSE");
960 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
961 if (o->op_private & OPpOPEN_IN_RAW)
962 sv_catpv(tmpsv, ",IN_RAW");
963 if (o->op_private & OPpOPEN_IN_CRLF)
964 sv_catpv(tmpsv, ",IN_CRLF");
965 if (o->op_private & OPpOPEN_OUT_RAW)
966 sv_catpv(tmpsv, ",OUT_RAW");
967 if (o->op_private & OPpOPEN_OUT_CRLF)
968 sv_catpv(tmpsv, ",OUT_CRLF");
970 else if (optype == OP_EXIT) {
971 if (o->op_private & OPpEXIT_VMSISH)
972 sv_catpv(tmpsv, ",EXIT_VMSISH");
973 if (o->op_private & OPpHUSH_VMSISH)
974 sv_catpv(tmpsv, ",HUSH_VMSISH");
976 else if (optype == OP_DIE) {
977 if (o->op_private & OPpHUSH_VMSISH)
978 sv_catpv(tmpsv, ",HUSH_VMSISH");
980 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
981 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
982 sv_catpv(tmpsv, ",FT_ACCESS");
983 if (o->op_private & OPpFT_STACKED)
984 sv_catpv(tmpsv, ",FT_STACKED");
986 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
987 sv_catpv(tmpsv, ",INTRO");
989 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
994 if (PL_madskills && o->op_madprop) {
995 SV * const tmpsv = newSVpvs("");
996 MADPROP* mp = o->op_madprop;
997 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1000 const char tmp = mp->mad_key;
1001 sv_setpvs(tmpsv,"'");
1003 sv_catpvn(tmpsv, &tmp, 1);
1004 sv_catpv(tmpsv, "'=");
1005 switch (mp->mad_type) {
1007 sv_catpv(tmpsv, "NULL");
1008 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1011 sv_catpv(tmpsv, "<");
1012 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1013 sv_catpv(tmpsv, ">");
1014 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1017 if ((OP*)mp->mad_val) {
1018 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1019 do_op_dump(level, file, (OP*)mp->mad_val);
1023 sv_catpv(tmpsv, "(UNK)");
1024 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1030 Perl_dump_indent(aTHX_ level, file, "}\n");
1032 SvREFCNT_dec(tmpsv);
1041 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1043 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1044 if (cSVOPo->op_sv) {
1045 SV * const tmpsv = newSV(0);
1049 /* FIXME - is this making unwarranted assumptions about the
1050 UTF-8 cleanliness of the dump file handle? */
1053 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1054 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1055 SvPV_nolen_const(tmpsv));
1059 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1065 case OP_METHOD_NAMED:
1066 #ifndef USE_ITHREADS
1067 /* with ITHREADS, consts are stored in the pad, and the right pad
1068 * may not be active here, so skip */
1069 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1075 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1076 (UV)CopLINE(cCOPo));
1077 if (CopSTASHPV(cCOPo))
1078 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1080 if (CopLABEL(cCOPo))
1081 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1085 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1086 if (cLOOPo->op_redoop)
1087 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1089 PerlIO_printf(file, "DONE\n");
1090 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1091 if (cLOOPo->op_nextop)
1092 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1094 PerlIO_printf(file, "DONE\n");
1095 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1096 if (cLOOPo->op_lastop)
1097 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1099 PerlIO_printf(file, "DONE\n");
1107 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1108 if (cLOGOPo->op_other)
1109 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1111 PerlIO_printf(file, "DONE\n");
1117 do_pmop_dump(level, file, cPMOPo);
1125 if (o->op_private & OPpREFCOUNTED)
1126 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1131 if (o->op_flags & OPf_KIDS) {
1133 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1134 do_op_dump(level, file, kid);
1136 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1140 Perl_op_dump(pTHX_ const OP *o)
1142 PERL_ARGS_ASSERT_OP_DUMP;
1143 do_op_dump(0, Perl_debug_log, o);
1147 Perl_gv_dump(pTHX_ GV *gv)
1151 PERL_ARGS_ASSERT_GV_DUMP;
1154 PerlIO_printf(Perl_debug_log, "{}\n");
1157 sv = sv_newmortal();
1158 PerlIO_printf(Perl_debug_log, "{\n");
1159 gv_fullname3(sv, gv, NULL);
1160 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1161 if (gv != GvEGV(gv)) {
1162 gv_efullname3(sv, GvEGV(gv), NULL);
1163 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1165 PerlIO_putc(Perl_debug_log, '\n');
1166 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1170 /* map magic types to the symbolic names
1171 * (with the PERL_MAGIC_ prefixed stripped)
1174 static const struct { const char type; const char *name; } magic_names[] = {
1175 { PERL_MAGIC_sv, "sv(\\0)" },
1176 { PERL_MAGIC_arylen, "arylen(#)" },
1177 { PERL_MAGIC_rhash, "rhash(%)" },
1178 { PERL_MAGIC_pos, "pos(.)" },
1179 { PERL_MAGIC_symtab, "symtab(:)" },
1180 { PERL_MAGIC_backref, "backref(<)" },
1181 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1182 { PERL_MAGIC_overload, "overload(A)" },
1183 { PERL_MAGIC_bm, "bm(B)" },
1184 { PERL_MAGIC_regdata, "regdata(D)" },
1185 { PERL_MAGIC_env, "env(E)" },
1186 { PERL_MAGIC_hints, "hints(H)" },
1187 { PERL_MAGIC_isa, "isa(I)" },
1188 { PERL_MAGIC_dbfile, "dbfile(L)" },
1189 { PERL_MAGIC_shared, "shared(N)" },
1190 { PERL_MAGIC_tied, "tied(P)" },
1191 { PERL_MAGIC_sig, "sig(S)" },
1192 { PERL_MAGIC_uvar, "uvar(U)" },
1193 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1194 { PERL_MAGIC_overload_table, "overload_table(c)" },
1195 { PERL_MAGIC_regdatum, "regdatum(d)" },
1196 { PERL_MAGIC_envelem, "envelem(e)" },
1197 { PERL_MAGIC_fm, "fm(f)" },
1198 { PERL_MAGIC_regex_global, "regex_global(g)" },
1199 { PERL_MAGIC_hintselem, "hintselem(h)" },
1200 { PERL_MAGIC_isaelem, "isaelem(i)" },
1201 { PERL_MAGIC_nkeys, "nkeys(k)" },
1202 { PERL_MAGIC_dbline, "dbline(l)" },
1203 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1204 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1205 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1206 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1207 { PERL_MAGIC_qr, "qr(r)" },
1208 { PERL_MAGIC_sigelem, "sigelem(s)" },
1209 { PERL_MAGIC_taint, "taint(t)" },
1210 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" },
1211 { PERL_MAGIC_vec, "vec(v)" },
1212 { PERL_MAGIC_vstring, "vstring(V)" },
1213 { PERL_MAGIC_utf8, "utf8(w)" },
1214 { PERL_MAGIC_substr, "substr(x)" },
1215 { PERL_MAGIC_defelem, "defelem(y)" },
1216 { PERL_MAGIC_ext, "ext(~)" },
1217 /* this null string terminates the list */
1222 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1224 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1226 for (; mg; mg = mg->mg_moremagic) {
1227 Perl_dump_indent(aTHX_ level, file,
1228 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1229 if (mg->mg_virtual) {
1230 const MGVTBL * const v = mg->mg_virtual;
1232 if (v == &PL_vtbl_sv) s = "sv";
1233 else if (v == &PL_vtbl_env) s = "env";
1234 else if (v == &PL_vtbl_envelem) s = "envelem";
1235 else if (v == &PL_vtbl_sig) s = "sig";
1236 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1237 else if (v == &PL_vtbl_pack) s = "pack";
1238 else if (v == &PL_vtbl_packelem) s = "packelem";
1239 else if (v == &PL_vtbl_dbline) s = "dbline";
1240 else if (v == &PL_vtbl_isa) s = "isa";
1241 else if (v == &PL_vtbl_arylen) s = "arylen";
1242 else if (v == &PL_vtbl_mglob) s = "mglob";
1243 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1244 else if (v == &PL_vtbl_taint) s = "taint";
1245 else if (v == &PL_vtbl_substr) s = "substr";
1246 else if (v == &PL_vtbl_vec) s = "vec";
1247 else if (v == &PL_vtbl_pos) s = "pos";
1248 else if (v == &PL_vtbl_bm) s = "bm";
1249 else if (v == &PL_vtbl_fm) s = "fm";
1250 else if (v == &PL_vtbl_uvar) s = "uvar";
1251 else if (v == &PL_vtbl_defelem) s = "defelem";
1252 #ifdef USE_LOCALE_COLLATE
1253 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1255 else if (v == &PL_vtbl_amagic) s = "amagic";
1256 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1257 else if (v == &PL_vtbl_backref) s = "backref";
1258 else if (v == &PL_vtbl_utf8) s = "utf8";
1259 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1260 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1263 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1265 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1268 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1271 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1275 const char *name = NULL;
1276 for (n = 0; magic_names[n].name; n++) {
1277 if (mg->mg_type == magic_names[n].type) {
1278 name = magic_names[n].name;
1283 Perl_dump_indent(aTHX_ level, file,
1284 " MG_TYPE = PERL_MAGIC_%s\n", name);
1286 Perl_dump_indent(aTHX_ level, file,
1287 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1291 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1292 if (mg->mg_type == PERL_MAGIC_envelem &&
1293 mg->mg_flags & MGf_TAINTEDDIR)
1294 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1295 if (mg->mg_flags & MGf_REFCOUNTED)
1296 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1297 if (mg->mg_flags & MGf_GSKIP)
1298 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1299 if (mg->mg_type == PERL_MAGIC_regex_global &&
1300 mg->mg_flags & MGf_MINMATCH)
1301 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1304 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1305 PTR2UV(mg->mg_obj));
1306 if (mg->mg_type == PERL_MAGIC_qr) {
1307 REGEXP* const re = (REGEXP *)mg->mg_obj;
1308 SV * const dsv = sv_newmortal();
1309 const char * const s
1310 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1312 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1313 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1315 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1316 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1319 if (mg->mg_flags & MGf_REFCOUNTED)
1320 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1323 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1325 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1326 if (mg->mg_len >= 0) {
1327 if (mg->mg_type != PERL_MAGIC_utf8) {
1328 SV * const sv = newSVpvs("");
1329 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1333 else if (mg->mg_len == HEf_SVKEY) {
1334 PerlIO_puts(file, " => HEf_SVKEY\n");
1335 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1336 maxnest, dumpops, pvlim); /* MG is already +1 */
1340 PerlIO_puts(file, " ???? - please notify IZ");
1341 PerlIO_putc(file, '\n');
1343 if (mg->mg_type == PERL_MAGIC_utf8) {
1344 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1347 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1348 Perl_dump_indent(aTHX_ level, file,
1349 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1352 (UV)cache[i * 2 + 1]);
1359 Perl_magic_dump(pTHX_ const MAGIC *mg)
1361 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1365 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1369 PERL_ARGS_ASSERT_DO_HV_DUMP;
1371 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1372 if (sv && (hvname = HvNAME_get(sv)))
1373 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1375 PerlIO_putc(file, '\n');
1379 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1381 PERL_ARGS_ASSERT_DO_GV_DUMP;
1383 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1384 if (sv && GvNAME(sv))
1385 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1387 PerlIO_putc(file, '\n');
1391 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1393 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1395 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1396 if (sv && GvNAME(sv)) {
1398 PerlIO_printf(file, "\t\"");
1399 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1400 PerlIO_printf(file, "%s\" :: \"", hvname);
1401 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1404 PerlIO_putc(file, '\n');
1408 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1416 PERL_ARGS_ASSERT_DO_SV_DUMP;
1419 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1423 flags = SvFLAGS(sv);
1426 d = Perl_newSVpvf(aTHX_
1427 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1428 PTR2UV(SvANY(sv)), PTR2UV(sv),
1429 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1430 (int)(PL_dumpindent*level), "");
1432 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1433 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1435 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1436 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1437 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1439 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1440 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1441 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1442 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1443 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1445 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1446 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1447 if (flags & SVf_POK) sv_catpv(d, "POK,");
1448 if (flags & SVf_ROK) {
1449 sv_catpv(d, "ROK,");
1450 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1452 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1453 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1454 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1455 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1457 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1458 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1459 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1460 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1461 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1462 if (SvPCS_IMPORTED(sv))
1463 sv_catpv(d, "PCS_IMPORTED,");
1465 sv_catpv(d, "SCREAM,");
1471 if (CvANON(sv)) sv_catpv(d, "ANON,");
1472 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1473 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1474 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1475 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1476 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1477 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1478 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1479 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1480 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1483 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1484 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1485 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1486 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1487 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1491 if (isGV_with_GP(sv)) {
1492 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1493 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1494 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1495 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1497 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1498 sv_catpv(d, "IMPORT");
1499 if (GvIMPORTED(sv) == GVf_IMPORTED)
1500 sv_catpv(d, "ALL,");
1503 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1504 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1505 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1506 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1510 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1511 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1515 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1516 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1519 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1520 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1523 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1528 /* SVphv_SHAREKEYS is also 0x20000000 */
1529 if ((type != SVt_PVHV) && SvUTF8(sv))
1530 sv_catpv(d, "UTF8");
1532 if (*(SvEND(d) - 1) == ',') {
1533 SvCUR_set(d, SvCUR(d) - 1);
1534 SvPVX(d)[SvCUR(d)] = '\0';
1539 #ifdef DEBUG_LEAKING_SCALARS
1540 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1541 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1543 sv->sv_debug_inpad ? "for" : "by",
1544 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1545 sv->sv_debug_cloned ? " (cloned)" : "");
1547 Perl_dump_indent(aTHX_ level, file, "SV = ");
1548 if (type < SVt_LAST) {
1549 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1551 if (type == SVt_NULL) {
1556 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1560 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1561 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM)
1562 || (type == SVt_IV && !SvROK(sv))) {
1564 #ifdef PERL_OLD_COPY_ON_WRITE
1568 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1570 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1571 #ifdef PERL_OLD_COPY_ON_WRITE
1572 if (SvIsCOW_shared_hash(sv))
1573 PerlIO_printf(file, " (HASH)");
1574 else if (SvIsCOW_normal(sv))
1575 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1577 PerlIO_putc(file, '\n');
1579 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1580 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1581 (UV) COP_SEQ_RANGE_LOW(sv));
1582 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1583 (UV) COP_SEQ_RANGE_HIGH(sv));
1584 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1585 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
1586 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1587 || type == SVt_NV) {
1588 STORE_NUMERIC_LOCAL_SET_STANDARD();
1589 /* %Vg doesn't work? --jhi */
1590 #ifdef USE_LONG_DOUBLE
1591 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1593 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1595 RESTORE_NUMERIC_LOCAL();
1598 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1600 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1602 if (type < SVt_PV) {
1606 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1607 if (SvPVX_const(sv)) {
1610 SvOOK_offset(sv, delta);
1611 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
1616 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1618 PerlIO_printf(file, "( %s . ) ",
1619 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1622 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1623 if (SvUTF8(sv)) /* the 6? \x{....} */
1624 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1625 PerlIO_printf(file, "\n");
1626 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1627 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1630 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1632 if (type == SVt_REGEXP) {
1634 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1635 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1638 if (type >= SVt_PVMG) {
1639 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1640 HV * const ost = SvOURSTASH(sv);
1642 do_hv_dump(level, file, " OURSTASH", ost);
1645 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1648 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1652 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1653 if (AvARRAY(sv) != AvALLOC(sv)) {
1654 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1655 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1658 PerlIO_putc(file, '\n');
1659 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1660 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1661 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1663 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1664 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1665 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1666 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1667 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1669 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1670 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1672 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1674 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1679 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1680 if (HvARRAY(sv) && HvKEYS(sv)) {
1681 /* Show distribution of HEs in the ARRAY */
1683 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1686 U32 pow2 = 2, keys = HvKEYS(sv);
1687 NV theoret, sum = 0;
1689 PerlIO_printf(file, " (");
1690 Zero(freq, FREQ_MAX + 1, int);
1691 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1694 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1696 if (count > FREQ_MAX)
1702 for (i = 0; i <= max; i++) {
1704 PerlIO_printf(file, "%d%s:%d", i,
1705 (i == FREQ_MAX) ? "+" : "",
1708 PerlIO_printf(file, ", ");
1711 PerlIO_putc(file, ')');
1712 /* The "quality" of a hash is defined as the total number of
1713 comparisons needed to access every element once, relative
1714 to the expected number needed for a random hash.
1716 The total number of comparisons is equal to the sum of
1717 the squares of the number of entries in each bucket.
1718 For a random hash of n keys into k buckets, the expected
1723 for (i = max; i > 0; i--) { /* Precision: count down. */
1724 sum += freq[i] * i * i;
1726 while ((keys = keys >> 1))
1728 theoret = HvKEYS(sv);
1729 theoret += theoret * (theoret-1)/pow2;
1730 PerlIO_putc(file, '\n');
1731 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1733 PerlIO_putc(file, '\n');
1734 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1735 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1736 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1737 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1738 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1740 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1741 if (mg && mg->mg_obj) {
1742 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1746 const char * const hvname = HvNAME_get(sv);
1748 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1752 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1753 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1755 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1757 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1761 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1762 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1763 (int)meta->mro_which->length,
1764 meta->mro_which->name,
1765 PTR2UV(meta->mro_which));
1766 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1767 (UV)meta->cache_gen);
1768 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1770 if (meta->mro_linear_all) {
1771 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1772 PTR2UV(meta->mro_linear_all));
1773 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1776 if (meta->mro_linear_current) {
1777 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1778 PTR2UV(meta->mro_linear_current));
1779 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1782 if (meta->mro_nextmethod) {
1783 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1784 PTR2UV(meta->mro_nextmethod));
1785 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1789 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1791 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1796 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1798 HV * const hv = MUTABLE_HV(sv);
1799 int count = maxnest - nest;
1802 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1805 const U32 hash = HeHASH(he);
1806 SV * const keysv = hv_iterkeysv(he);
1807 const char * const keypv = SvPV_const(keysv, len);
1808 SV * const elt = hv_iterval(hv, he);
1810 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1812 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1814 PerlIO_printf(file, "[REHASH] ");
1815 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1816 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1818 hv_iterinit(hv); /* Return to status quo */
1824 const char *const proto = SvPV_const(sv, len);
1825 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1830 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1831 if (!CvISXSUB(sv)) {
1833 Perl_dump_indent(aTHX_ level, file,
1834 " START = 0x%"UVxf" ===> %"IVdf"\n",
1835 PTR2UV(CvSTART(sv)),
1836 (IV)sequence_num(CvSTART(sv)));
1838 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1839 PTR2UV(CvROOT(sv)));
1840 if (CvROOT(sv) && dumpops) {
1841 do_op_dump(level+1, file, CvROOT(sv));
1844 SV * const constant = cv_const_sv((const CV *)sv);
1846 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1849 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1851 PTR2UV(CvXSUBANY(sv).any_ptr));
1852 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1855 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1856 (IV)CvXSUBANY(sv).any_i32);
1859 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1860 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1861 if (type == SVt_PVCV)
1862 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1863 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1864 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1865 if (type == SVt_PVFM)
1866 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1867 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1868 if (nest < maxnest) {
1869 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1872 const CV * const outside = CvOUTSIDE(sv);
1873 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1876 : CvANON(outside) ? "ANON"
1877 : (outside == PL_main_cv) ? "MAIN"
1878 : CvUNIQUE(outside) ? "UNIQUE"
1879 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1881 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1882 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1886 if (type == SVt_PVLV) {
1887 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1888 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1889 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1890 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1891 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1892 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1896 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1897 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1898 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1899 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1901 if (!isGV_with_GP(sv))
1903 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1904 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1905 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1906 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1909 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1910 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1911 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1912 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1913 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1914 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1915 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1916 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1917 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1918 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1919 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1920 do_gv_dump (level, file, " EGV", GvEGV(sv));
1923 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1924 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1925 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1926 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1927 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1928 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1929 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1931 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1932 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1933 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1935 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1936 PTR2UV(IoTOP_GV(sv)));
1937 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1938 maxnest, dumpops, pvlim);
1940 /* Source filters hide things that are not GVs in these three, so let's
1941 be careful out there. */
1943 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1944 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1945 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1947 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1948 PTR2UV(IoFMT_GV(sv)));
1949 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1950 maxnest, dumpops, pvlim);
1952 if (IoBOTTOM_NAME(sv))
1953 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1954 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1955 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1957 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1958 PTR2UV(IoBOTTOM_GV(sv)));
1959 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
1960 maxnest, dumpops, pvlim);
1962 if (isPRINT(IoTYPE(sv)))
1963 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1965 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1966 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1973 Perl_sv_dump(pTHX_ SV *sv)
1977 PERL_ARGS_ASSERT_SV_DUMP;
1980 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1982 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1986 Perl_runops_debug(pTHX)
1990 if (ckWARN_d(WARN_DEBUGGING))
1991 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1995 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1999 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2000 PerlIO_printf(Perl_debug_log,
2001 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2002 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2003 PTR2UV(*PL_watchaddr));
2004 if (DEBUG_s_TEST_) {
2005 if (DEBUG_v_TEST_) {
2006 PerlIO_printf(Perl_debug_log, "\n");
2014 if (DEBUG_t_TEST_) debop(PL_op);
2015 if (DEBUG_P_TEST_) debprof(PL_op);
2017 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2018 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2025 Perl_debop(pTHX_ const OP *o)
2029 PERL_ARGS_ASSERT_DEBOP;
2031 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2034 Perl_deb(aTHX_ "%s", OP_NAME(o));
2035 switch (o->op_type) {
2038 /* With ITHREADS, consts are stored in the pad, and the right pad
2039 * may not be active here, so check.
2040 * Looks like only during compiling the pads are illegal.
2043 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2045 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2050 SV * const sv = newSV(0);
2052 /* FIXME - is this making unwarranted assumptions about the
2053 UTF-8 cleanliness of the dump file handle? */
2056 gv_fullname3(sv, cGVOPo_gv, NULL);
2057 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2061 PerlIO_printf(Perl_debug_log, "(NULL)");
2067 /* print the lexical's name */
2068 CV * const cv = deb_curcv(cxstack_ix);
2071 AV * const padlist = CvPADLIST(cv);
2072 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2073 sv = *av_fetch(comppad, o->op_targ, FALSE);
2077 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2079 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2085 PerlIO_printf(Perl_debug_log, "\n");
2090 S_deb_curcv(pTHX_ const I32 ix)
2093 const PERL_CONTEXT * const cx = &cxstack[ix];
2094 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2095 return cx->blk_sub.cv;
2096 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2098 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2103 return deb_curcv(ix - 1);
2107 Perl_watch(pTHX_ char **addr)
2111 PERL_ARGS_ASSERT_WATCH;
2113 PL_watchaddr = addr;
2115 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2116 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2120 S_debprof(pTHX_ const OP *o)
2124 PERL_ARGS_ASSERT_DEBPROF;
2126 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2128 if (!PL_profiledata)
2129 Newxz(PL_profiledata, MAXO, U32);
2130 ++PL_profiledata[o->op_type];
2134 Perl_debprofdump(pTHX)
2138 if (!PL_profiledata)
2140 for (i = 0; i < MAXO; i++) {
2141 if (PL_profiledata[i])
2142 PerlIO_printf(Perl_debug_log,
2143 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2150 * XML variants of most of the above routines
2154 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2158 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2160 PerlIO_printf(file, "\n ");
2161 va_start(args, pat);
2162 xmldump_vindent(level, file, pat, &args);
2168 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2171 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2172 va_start(args, pat);
2173 xmldump_vindent(level, file, pat, &args);
2178 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2180 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2182 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2183 PerlIO_vprintf(file, pat, *args);
2187 Perl_xmldump_all(pTHX)
2189 PerlIO_setlinebuf(PL_xmlfp);
2191 op_xmldump(PL_main_root);
2192 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2193 PerlIO_close(PL_xmlfp);
2198 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2203 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2205 if (!HvARRAY(stash))
2207 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2208 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2209 GV *gv = MUTABLE_GV(HeVAL(entry));
2211 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2217 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2218 && (hv = GvHV(gv)) && hv != PL_defstash)
2219 xmldump_packsubs(hv); /* nested package */
2225 Perl_xmldump_sub(pTHX_ const GV *gv)
2227 SV * const sv = sv_newmortal();
2229 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2231 gv_fullname3(sv, gv, NULL);
2232 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2233 if (CvXSUB(GvCV(gv)))
2234 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2235 PTR2UV(CvXSUB(GvCV(gv))),
2236 (int)CvXSUBANY(GvCV(gv)).any_i32);
2237 else if (CvROOT(GvCV(gv)))
2238 op_xmldump(CvROOT(GvCV(gv)));
2240 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2244 Perl_xmldump_form(pTHX_ const GV *gv)
2246 SV * const sv = sv_newmortal();
2248 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2250 gv_fullname3(sv, gv, NULL);
2251 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2252 if (CvROOT(GvFORM(gv)))
2253 op_xmldump(CvROOT(GvFORM(gv)));
2255 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2259 Perl_xmldump_eval(pTHX)
2261 op_xmldump(PL_eval_root);
2265 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2267 PERL_ARGS_ASSERT_SV_CATXMLSV;
2268 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2272 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2275 const char * const e = pv + len;
2276 const char * const start = pv;
2280 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2283 dsvcur = SvCUR(dsv); /* in case we have to restart */
2288 c = utf8_to_uvchr((U8*)pv, &cl);
2290 SvCUR(dsv) = dsvcur;
2355 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2358 sv_catpvs(dsv, "<");
2361 sv_catpvs(dsv, ">");
2364 sv_catpvs(dsv, "&");
2367 sv_catpvs(dsv, """);
2371 if (c < 32 || c > 127) {
2372 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2375 const char string = (char) c;
2376 sv_catpvn(dsv, &string, 1);
2380 if ((c >= 0xD800 && c <= 0xDB7F) ||
2381 (c >= 0xDC00 && c <= 0xDFFF) ||
2382 (c >= 0xFFF0 && c <= 0xFFFF) ||
2384 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2386 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2399 Perl_sv_xmlpeek(pTHX_ SV *sv)
2401 SV * const t = sv_newmortal();
2405 PERL_ARGS_ASSERT_SV_XMLPEEK;
2411 sv_catpv(t, "VOID=\"\"");
2414 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2415 sv_catpv(t, "WILD=\"\"");
2418 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2419 if (sv == &PL_sv_undef) {
2420 sv_catpv(t, "SV_UNDEF=\"1\"");
2421 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2422 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2426 else if (sv == &PL_sv_no) {
2427 sv_catpv(t, "SV_NO=\"1\"");
2428 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2429 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2430 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2431 SVp_POK|SVp_NOK)) &&
2436 else if (sv == &PL_sv_yes) {
2437 sv_catpv(t, "SV_YES=\"1\"");
2438 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2439 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2440 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2441 SVp_POK|SVp_NOK)) &&
2443 SvPVX(sv) && *SvPVX(sv) == '1' &&
2448 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2449 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2450 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2454 sv_catpv(t, " XXX=\"\" ");
2456 else if (SvREFCNT(sv) == 0) {
2457 sv_catpv(t, " refcnt=\"0\"");
2460 else if (DEBUG_R_TEST_) {
2463 /* is this SV on the tmps stack? */
2464 for (ix=PL_tmps_ix; ix>=0; ix--) {
2465 if (PL_tmps_stack[ix] == sv) {
2470 if (SvREFCNT(sv) > 1)
2471 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2474 sv_catpv(t, " DRT=\"<T>\"");
2478 sv_catpv(t, " ROK=\"\"");
2480 switch (SvTYPE(sv)) {
2482 sv_catpv(t, " FREED=\"1\"");
2486 sv_catpv(t, " UNDEF=\"1\"");
2489 sv_catpv(t, " IV=\"");
2492 sv_catpv(t, " NV=\"");
2495 sv_catpv(t, " PV=\"");
2498 sv_catpv(t, " PVIV=\"");
2501 sv_catpv(t, " PVNV=\"");
2504 sv_catpv(t, " PVMG=\"");
2507 sv_catpv(t, " PVLV=\"");
2510 sv_catpv(t, " AV=\"");
2513 sv_catpv(t, " HV=\"");
2517 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2519 sv_catpv(t, " CV=\"()\"");
2522 sv_catpv(t, " GV=\"");
2525 sv_catpv(t, " BIND=\"");
2528 sv_catpv(t, " ORANGE=\"");
2531 sv_catpv(t, " FM=\"");
2534 sv_catpv(t, " IO=\"");
2543 else if (SvNOKp(sv)) {
2544 STORE_NUMERIC_LOCAL_SET_STANDARD();
2545 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2546 RESTORE_NUMERIC_LOCAL();
2548 else if (SvIOKp(sv)) {
2550 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2552 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2561 return SvPV(t, n_a);
2565 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2567 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2570 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2573 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2576 REGEXP *const r = PM_GETRE(pm);
2577 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2578 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2579 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2581 SvREFCNT_dec(tmpsv);
2582 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2583 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2586 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2587 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2588 SV * const tmpsv = pm_description(pm);
2589 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2590 SvREFCNT_dec(tmpsv);
2594 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2595 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2596 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2597 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2598 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2599 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2602 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2606 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2608 do_pmop_xmldump(0, PL_xmlfp, pm);
2612 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2617 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2622 seq = sequence_num(o);
2623 Perl_xmldump_indent(aTHX_ level, file,
2624 "<op_%s seq=\"%"UVuf" -> ",
2629 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2630 sequence_num(o->op_next));
2632 PerlIO_printf(file, "DONE\"");
2635 if (o->op_type == OP_NULL)
2637 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2638 if (o->op_targ == OP_NEXTSTATE)
2641 PerlIO_printf(file, " line=\"%"UVuf"\"",
2642 (UV)CopLINE(cCOPo));
2643 if (CopSTASHPV(cCOPo))
2644 PerlIO_printf(file, " package=\"%s\"",
2646 if (CopLABEL(cCOPo))
2647 PerlIO_printf(file, " label=\"%s\"",
2652 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2655 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2658 SV * const tmpsv = newSVpvs("");
2659 switch (o->op_flags & OPf_WANT) {
2661 sv_catpv(tmpsv, ",VOID");
2663 case OPf_WANT_SCALAR:
2664 sv_catpv(tmpsv, ",SCALAR");
2667 sv_catpv(tmpsv, ",LIST");
2670 sv_catpv(tmpsv, ",UNKNOWN");
2673 if (o->op_flags & OPf_KIDS)
2674 sv_catpv(tmpsv, ",KIDS");
2675 if (o->op_flags & OPf_PARENS)
2676 sv_catpv(tmpsv, ",PARENS");
2677 if (o->op_flags & OPf_STACKED)
2678 sv_catpv(tmpsv, ",STACKED");
2679 if (o->op_flags & OPf_REF)
2680 sv_catpv(tmpsv, ",REF");
2681 if (o->op_flags & OPf_MOD)
2682 sv_catpv(tmpsv, ",MOD");
2683 if (o->op_flags & OPf_SPECIAL)
2684 sv_catpv(tmpsv, ",SPECIAL");
2685 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2686 SvREFCNT_dec(tmpsv);
2688 if (o->op_private) {
2689 SV * const tmpsv = newSVpvs("");
2690 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2691 if (o->op_private & OPpTARGET_MY)
2692 sv_catpv(tmpsv, ",TARGET_MY");
2694 else if (o->op_type == OP_LEAVESUB ||
2695 o->op_type == OP_LEAVE ||
2696 o->op_type == OP_LEAVESUBLV ||
2697 o->op_type == OP_LEAVEWRITE) {
2698 if (o->op_private & OPpREFCOUNTED)
2699 sv_catpv(tmpsv, ",REFCOUNTED");
2701 else if (o->op_type == OP_AASSIGN) {
2702 if (o->op_private & OPpASSIGN_COMMON)
2703 sv_catpv(tmpsv, ",COMMON");
2705 else if (o->op_type == OP_SASSIGN) {
2706 if (o->op_private & OPpASSIGN_BACKWARDS)
2707 sv_catpv(tmpsv, ",BACKWARDS");
2709 else if (o->op_type == OP_TRANS) {
2710 if (o->op_private & OPpTRANS_SQUASH)
2711 sv_catpv(tmpsv, ",SQUASH");
2712 if (o->op_private & OPpTRANS_DELETE)
2713 sv_catpv(tmpsv, ",DELETE");
2714 if (o->op_private & OPpTRANS_COMPLEMENT)
2715 sv_catpv(tmpsv, ",COMPLEMENT");
2716 if (o->op_private & OPpTRANS_IDENTICAL)
2717 sv_catpv(tmpsv, ",IDENTICAL");
2718 if (o->op_private & OPpTRANS_GROWS)
2719 sv_catpv(tmpsv, ",GROWS");
2721 else if (o->op_type == OP_REPEAT) {
2722 if (o->op_private & OPpREPEAT_DOLIST)
2723 sv_catpv(tmpsv, ",DOLIST");
2725 else if (o->op_type == OP_ENTERSUB ||
2726 o->op_type == OP_RV2SV ||
2727 o->op_type == OP_GVSV ||
2728 o->op_type == OP_RV2AV ||
2729 o->op_type == OP_RV2HV ||
2730 o->op_type == OP_RV2GV ||
2731 o->op_type == OP_AELEM ||
2732 o->op_type == OP_HELEM )
2734 if (o->op_type == OP_ENTERSUB) {
2735 if (o->op_private & OPpENTERSUB_AMPER)
2736 sv_catpv(tmpsv, ",AMPER");
2737 if (o->op_private & OPpENTERSUB_DB)
2738 sv_catpv(tmpsv, ",DB");
2739 if (o->op_private & OPpENTERSUB_HASTARG)
2740 sv_catpv(tmpsv, ",HASTARG");
2741 if (o->op_private & OPpENTERSUB_NOPAREN)
2742 sv_catpv(tmpsv, ",NOPAREN");
2743 if (o->op_private & OPpENTERSUB_INARGS)
2744 sv_catpv(tmpsv, ",INARGS");
2745 if (o->op_private & OPpENTERSUB_NOMOD)
2746 sv_catpv(tmpsv, ",NOMOD");
2749 switch (o->op_private & OPpDEREF) {
2751 sv_catpv(tmpsv, ",SV");
2754 sv_catpv(tmpsv, ",AV");
2757 sv_catpv(tmpsv, ",HV");
2760 if (o->op_private & OPpMAYBE_LVSUB)
2761 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2763 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2764 if (o->op_private & OPpLVAL_DEFER)
2765 sv_catpv(tmpsv, ",LVAL_DEFER");
2768 if (o->op_private & HINT_STRICT_REFS)
2769 sv_catpv(tmpsv, ",STRICT_REFS");
2770 if (o->op_private & OPpOUR_INTRO)
2771 sv_catpv(tmpsv, ",OUR_INTRO");
2774 else if (o->op_type == OP_CONST) {
2775 if (o->op_private & OPpCONST_BARE)
2776 sv_catpv(tmpsv, ",BARE");
2777 if (o->op_private & OPpCONST_STRICT)
2778 sv_catpv(tmpsv, ",STRICT");
2779 if (o->op_private & OPpCONST_ARYBASE)
2780 sv_catpv(tmpsv, ",ARYBASE");
2781 if (o->op_private & OPpCONST_WARNING)
2782 sv_catpv(tmpsv, ",WARNING");
2783 if (o->op_private & OPpCONST_ENTERED)
2784 sv_catpv(tmpsv, ",ENTERED");
2786 else if (o->op_type == OP_FLIP) {
2787 if (o->op_private & OPpFLIP_LINENUM)
2788 sv_catpv(tmpsv, ",LINENUM");
2790 else if (o->op_type == OP_FLOP) {
2791 if (o->op_private & OPpFLIP_LINENUM)
2792 sv_catpv(tmpsv, ",LINENUM");
2794 else if (o->op_type == OP_RV2CV) {
2795 if (o->op_private & OPpLVAL_INTRO)
2796 sv_catpv(tmpsv, ",INTRO");
2798 else if (o->op_type == OP_GV) {
2799 if (o->op_private & OPpEARLY_CV)
2800 sv_catpv(tmpsv, ",EARLY_CV");
2802 else if (o->op_type == OP_LIST) {
2803 if (o->op_private & OPpLIST_GUESSED)
2804 sv_catpv(tmpsv, ",GUESSED");
2806 else if (o->op_type == OP_DELETE) {
2807 if (o->op_private & OPpSLICE)
2808 sv_catpv(tmpsv, ",SLICE");
2810 else if (o->op_type == OP_EXISTS) {
2811 if (o->op_private & OPpEXISTS_SUB)
2812 sv_catpv(tmpsv, ",EXISTS_SUB");
2814 else if (o->op_type == OP_SORT) {
2815 if (o->op_private & OPpSORT_NUMERIC)
2816 sv_catpv(tmpsv, ",NUMERIC");
2817 if (o->op_private & OPpSORT_INTEGER)
2818 sv_catpv(tmpsv, ",INTEGER");
2819 if (o->op_private & OPpSORT_REVERSE)
2820 sv_catpv(tmpsv, ",REVERSE");
2822 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2823 if (o->op_private & OPpOPEN_IN_RAW)
2824 sv_catpv(tmpsv, ",IN_RAW");
2825 if (o->op_private & OPpOPEN_IN_CRLF)
2826 sv_catpv(tmpsv, ",IN_CRLF");
2827 if (o->op_private & OPpOPEN_OUT_RAW)
2828 sv_catpv(tmpsv, ",OUT_RAW");
2829 if (o->op_private & OPpOPEN_OUT_CRLF)
2830 sv_catpv(tmpsv, ",OUT_CRLF");
2832 else if (o->op_type == OP_EXIT) {
2833 if (o->op_private & OPpEXIT_VMSISH)
2834 sv_catpv(tmpsv, ",EXIT_VMSISH");
2835 if (o->op_private & OPpHUSH_VMSISH)
2836 sv_catpv(tmpsv, ",HUSH_VMSISH");
2838 else if (o->op_type == OP_DIE) {
2839 if (o->op_private & OPpHUSH_VMSISH)
2840 sv_catpv(tmpsv, ",HUSH_VMSISH");
2842 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2843 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2844 sv_catpv(tmpsv, ",FT_ACCESS");
2845 if (o->op_private & OPpFT_STACKED)
2846 sv_catpv(tmpsv, ",FT_STACKED");
2848 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2849 sv_catpv(tmpsv, ",INTRO");
2851 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2852 SvREFCNT_dec(tmpsv);
2855 switch (o->op_type) {
2857 if (o->op_flags & OPf_SPECIAL) {
2863 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2865 if (cSVOPo->op_sv) {
2866 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2867 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2873 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2874 s = SvPV(tmpsv1,len);
2875 sv_catxmlpvn(tmpsv2, s, len, 1);
2876 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2880 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2885 case OP_METHOD_NAMED:
2886 #ifndef USE_ITHREADS
2887 /* with ITHREADS, consts are stored in the pad, and the right pad
2888 * may not be active here, so skip */
2889 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2895 PerlIO_printf(file, ">\n");
2897 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2902 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2903 (UV)CopLINE(cCOPo));
2904 if (CopSTASHPV(cCOPo))
2905 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2907 if (CopLABEL(cCOPo))
2908 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2912 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2913 if (cLOOPo->op_redoop)
2914 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2916 PerlIO_printf(file, "DONE\"");
2917 S_xmldump_attr(aTHX_ level, file, "next=\"");
2918 if (cLOOPo->op_nextop)
2919 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2921 PerlIO_printf(file, "DONE\"");
2922 S_xmldump_attr(aTHX_ level, file, "last=\"");
2923 if (cLOOPo->op_lastop)
2924 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2926 PerlIO_printf(file, "DONE\"");
2934 S_xmldump_attr(aTHX_ level, file, "other=\"");
2935 if (cLOGOPo->op_other)
2936 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2938 PerlIO_printf(file, "DONE\"");
2946 if (o->op_private & OPpREFCOUNTED)
2947 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2953 if (PL_madskills && o->op_madprop) {
2954 char prevkey = '\0';
2955 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2956 const MADPROP* mp = o->op_madprop;
2960 PerlIO_printf(file, ">\n");
2962 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2965 char tmp = mp->mad_key;
2966 sv_setpvs(tmpsv,"\"");
2968 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2969 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2970 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2973 sv_catpv(tmpsv, "\"");
2974 switch (mp->mad_type) {
2976 sv_catpv(tmpsv, "NULL");
2977 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2980 sv_catpv(tmpsv, " val=\"");
2981 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2982 sv_catpv(tmpsv, "\"");
2983 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2986 sv_catpv(tmpsv, " val=\"");
2987 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
2988 sv_catpv(tmpsv, "\"");
2989 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2992 if ((OP*)mp->mad_val) {
2993 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2994 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2995 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2999 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3005 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3007 SvREFCNT_dec(tmpsv);
3010 switch (o->op_type) {
3017 PerlIO_printf(file, ">\n");
3019 do_pmop_xmldump(level, file, cPMOPo);
3025 if (o->op_flags & OPf_KIDS) {
3029 PerlIO_printf(file, ">\n");
3031 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3032 do_op_xmldump(level, file, kid);
3036 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3038 PerlIO_printf(file, " />\n");
3042 Perl_op_xmldump(pTHX_ const OP *o)
3044 PERL_ARGS_ASSERT_OP_XMLDUMP;
3046 do_op_xmldump(0, PL_xmlfp, o);
3052 * c-indentation-style: bsd
3054 * indent-tabs-mode: t
3057 * ex: set ts=8 sts=4 sw=4 noet: