3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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.'"
16 /* This file contains utility routines to dump the contents of SV and OP
17 * structures, as used by command-line options like -Dt and -Dx, and
20 * It also holds the debugging version of the runops function.
24 #define PERL_IN_DUMP_C
30 static const char* const svtypenames[SVt_LAST] = {
50 static const char* const svshorttypenames[SVt_LAST] = {
69 #define Sequence PL_op_sequence
72 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
75 PERL_ARGS_ASSERT_DUMP_INDENT;
77 dump_vindent(level, file, pat, &args);
82 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
85 PERL_ARGS_ASSERT_DUMP_VINDENT;
86 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
87 PerlIO_vprintf(file, pat, *args);
94 PerlIO_setlinebuf(Perl_debug_log);
96 op_dump(PL_main_root);
97 dump_packsubs(PL_defstash);
101 Perl_dump_packsubs(pTHX_ const HV *stash)
106 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
110 for (i = 0; i <= (I32) HvMAX(stash); i++) {
112 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
113 const GV * const gv = (GV*)HeVAL(entry);
114 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
120 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
121 const HV * const hv = GvHV(gv);
122 if (hv && (hv != PL_defstash))
123 dump_packsubs(hv); /* nested package */
130 Perl_dump_sub(pTHX_ const GV *gv)
132 SV * const sv = sv_newmortal();
134 PERL_ARGS_ASSERT_DUMP_SUB;
136 gv_fullname3(sv, gv, NULL);
137 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
138 if (CvISXSUB(GvCV(gv)))
139 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
140 PTR2UV(CvXSUB(GvCV(gv))),
141 (int)CvXSUBANY(GvCV(gv)).any_i32);
142 else if (CvROOT(GvCV(gv)))
143 op_dump(CvROOT(GvCV(gv)));
145 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
149 Perl_dump_form(pTHX_ const GV *gv)
151 SV * const sv = sv_newmortal();
153 PERL_ARGS_ASSERT_DUMP_FORM;
155 gv_fullname3(sv, gv, NULL);
156 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
157 if (CvROOT(GvFORM(gv)))
158 op_dump(CvROOT(GvFORM(gv)));
160 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
167 op_dump(PL_eval_root);
172 =for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\
173 |const STRLEN count|const STRLEN max
174 |STRLEN const *escaped, const U32 flags
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 */
234 sv_setpvn(dsv, "", 0);
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 Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
312 |const STRLEN count|const STRLEN max\
313 |const char const *start_color| const char const *end_color\
316 Converts a string into something presentable, handling escaping via
317 pv_escape() and supporting quoting and ellipses.
319 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
320 double quoted with any double quotes in the string escaped. Otherwise
321 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
324 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
325 string were output then an ellipsis C<...> will be appended to the
326 string. Note that this happens AFTER it has been quoted.
328 If start_color is non-null then it will be inserted after the opening
329 quote (if there is one) but before the escaped text. If end_color
330 is non-null then it will be inserted after the escaped text but before
331 any quotes or ellipses.
333 Returns a pointer to the prettified text as held by dsv.
339 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
340 const STRLEN max, char const * const start_color, char const * const end_color,
343 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
346 PERL_ARGS_ASSERT_PV_PRETTY;
348 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
349 /* This won't alter the UTF-8 flag */
350 sv_setpvn(dsv, "", 0);
354 sv_catpvn(dsv, "\"", 1);
355 else if ( flags & PERL_PV_PRETTY_LTGT )
356 sv_catpvn(dsv, "<", 1);
358 if ( start_color != NULL )
359 Perl_sv_catpv( aTHX_ dsv, start_color);
361 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
363 if ( end_color != NULL )
364 Perl_sv_catpv( aTHX_ dsv, end_color);
367 sv_catpvn( dsv, "\"", 1 );
368 else if ( flags & PERL_PV_PRETTY_LTGT )
369 sv_catpvn( dsv, ">", 1);
371 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
372 sv_catpvn( dsv, "...", 3 );
378 =for apidoc pv_display
380 char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
381 STRLEN pvlim, U32 flags)
385 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
387 except that an additional "\0" will be appended to the string when
388 len > cur and pv[cur] is "\0".
390 Note that the final string may be up to 7 chars longer than pvlim.
396 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
398 PERL_ARGS_ASSERT_PV_DISPLAY;
400 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
401 if (len > cur && pv[cur] == '\0')
402 sv_catpvn( dsv, "\\0", 2 );
407 Perl_sv_peek(pTHX_ SV *sv)
410 SV * const t = sv_newmortal();
420 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
424 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
425 if (sv == &PL_sv_undef) {
426 sv_catpv(t, "SV_UNDEF");
427 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
428 SVs_GMG|SVs_SMG|SVs_RMG)) &&
432 else if (sv == &PL_sv_no) {
433 sv_catpv(t, "SV_NO");
434 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
435 SVs_GMG|SVs_SMG|SVs_RMG)) &&
436 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
442 else if (sv == &PL_sv_yes) {
443 sv_catpv(t, "SV_YES");
444 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
445 SVs_GMG|SVs_SMG|SVs_RMG)) &&
446 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
449 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
454 sv_catpv(t, "SV_PLACEHOLDER");
455 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
456 SVs_GMG|SVs_SMG|SVs_RMG)) &&
462 else if (SvREFCNT(sv) == 0) {
466 else if (DEBUG_R_TEST_) {
469 /* is this SV on the tmps stack? */
470 for (ix=PL_tmps_ix; ix>=0; ix--) {
471 if (PL_tmps_stack[ix] == sv) {
476 if (SvREFCNT(sv) > 1)
477 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
485 if (SvCUR(t) + unref > 10) {
486 SvCUR_set(t, unref + 3);
495 if (type == SVt_PVCV) {
496 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
498 } else if (type < SVt_LAST) {
499 sv_catpv(t, svshorttypenames[type]);
501 if (type == SVt_NULL)
504 sv_catpv(t, "FREED");
509 if (!SvPVX_const(sv))
510 sv_catpv(t, "(null)");
512 SV * const tmp = newSVpvs("");
515 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
516 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
518 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
519 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
524 else if (SvNOKp(sv)) {
525 STORE_NUMERIC_LOCAL_SET_STANDARD();
526 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
527 RESTORE_NUMERIC_LOCAL();
529 else if (SvIOKp(sv)) {
531 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
533 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
541 return SvPV_nolen(t);
545 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
549 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
552 Perl_dump_indent(aTHX_ level, file, "{}\n");
555 Perl_dump_indent(aTHX_ level, file, "{\n");
557 if (pm->op_pmflags & PMf_ONCE)
562 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
563 ch, RX_PRECOMP(PM_GETRE(pm)), ch,
564 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
566 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
567 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
568 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
569 op_dump(pm->op_pmreplrootu.op_pmreplroot);
571 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
572 SV * const tmpsv = pm_description(pm);
573 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
577 Perl_dump_indent(aTHX_ level-1, file, "}\n");
581 S_pm_description(pTHX_ const PMOP *pm)
583 SV * const desc = newSVpvs("");
584 const REGEXP * const regex = PM_GETRE(pm);
585 const U32 pmflags = pm->op_pmflags;
587 PERL_ARGS_ASSERT_PM_DESCRIPTION;
589 if (pmflags & PMf_ONCE)
590 sv_catpv(desc, ",ONCE");
592 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
593 sv_catpv(desc, ":USED");
595 if (pmflags & PMf_USED)
596 sv_catpv(desc, ":USED");
600 if (RX_EXTFLAGS(regex) & RXf_TAINTED)
601 sv_catpv(desc, ",TAINTED");
602 if (RX_CHECK_SUBSTR(regex)) {
603 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
604 sv_catpv(desc, ",SCANFIRST");
605 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
606 sv_catpv(desc, ",ALL");
608 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
609 sv_catpv(desc, ",SKIPWHITE");
612 if (pmflags & PMf_CONST)
613 sv_catpv(desc, ",CONST");
614 if (pmflags & PMf_KEEP)
615 sv_catpv(desc, ",KEEP");
616 if (pmflags & PMf_GLOBAL)
617 sv_catpv(desc, ",GLOBAL");
618 if (pmflags & PMf_CONTINUE)
619 sv_catpv(desc, ",CONTINUE");
620 if (pmflags & PMf_RETAINT)
621 sv_catpv(desc, ",RETAINT");
622 if (pmflags & PMf_EVAL)
623 sv_catpv(desc, ",EVAL");
628 Perl_pmop_dump(pTHX_ PMOP *pm)
630 do_pmop_dump(0, Perl_debug_log, pm);
633 /* An op sequencer. We visit the ops in the order they're to execute. */
636 S_sequence(pTHX_ register const OP *o)
639 const OP *oldop = NULL;
652 for (; o; o = o->op_next) {
654 SV * const op = newSVuv(PTR2UV(o));
655 const char * const key = SvPV_const(op, len);
657 if (hv_exists(Sequence, key, len))
660 switch (o->op_type) {
662 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
663 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
672 if (oldop && o->op_next)
679 if (oldop && o->op_next)
681 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
694 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
695 sequence_tail(cLOGOPo->op_other);
700 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
701 sequence_tail(cLOOPo->op_redoop);
702 sequence_tail(cLOOPo->op_nextop);
703 sequence_tail(cLOOPo->op_lastop);
707 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
708 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
717 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
725 S_sequence_tail(pTHX_ const OP *o)
727 while (o && (o->op_type == OP_NULL))
733 S_sequence_num(pTHX_ const OP *o)
741 op = newSVuv(PTR2UV(o));
742 key = SvPV_const(op, len);
743 seq = hv_fetch(Sequence, key, len, 0);
744 return seq ? SvUV(*seq): 0;
748 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
752 const OPCODE optype = o->op_type;
754 PERL_ARGS_ASSERT_DO_OP_DUMP;
757 Perl_dump_indent(aTHX_ level, file, "{\n");
759 seq = sequence_num(o);
761 PerlIO_printf(file, "%-4"UVuf, seq);
763 PerlIO_printf(file, " ");
765 "%*sTYPE = %s ===> ",
766 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
768 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
769 sequence_num(o->op_next));
771 PerlIO_printf(file, "DONE\n");
773 if (optype == OP_NULL) {
774 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
775 if (o->op_targ == OP_NEXTSTATE) {
777 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
779 if (CopSTASHPV(cCOPo))
780 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
782 if (cCOPo->cop_label)
783 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
788 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
791 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
793 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
794 SV * const tmpsv = newSVpvs("");
795 switch (o->op_flags & OPf_WANT) {
797 sv_catpv(tmpsv, ",VOID");
799 case OPf_WANT_SCALAR:
800 sv_catpv(tmpsv, ",SCALAR");
803 sv_catpv(tmpsv, ",LIST");
806 sv_catpv(tmpsv, ",UNKNOWN");
809 if (o->op_flags & OPf_KIDS)
810 sv_catpv(tmpsv, ",KIDS");
811 if (o->op_flags & OPf_PARENS)
812 sv_catpv(tmpsv, ",PARENS");
813 if (o->op_flags & OPf_STACKED)
814 sv_catpv(tmpsv, ",STACKED");
815 if (o->op_flags & OPf_REF)
816 sv_catpv(tmpsv, ",REF");
817 if (o->op_flags & OPf_MOD)
818 sv_catpv(tmpsv, ",MOD");
819 if (o->op_flags & OPf_SPECIAL)
820 sv_catpv(tmpsv, ",SPECIAL");
822 sv_catpv(tmpsv, ",LATEFREE");
824 sv_catpv(tmpsv, ",LATEFREED");
826 sv_catpv(tmpsv, ",ATTACHED");
827 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
831 SV * const tmpsv = newSVpvs("");
832 if (PL_opargs[optype] & OA_TARGLEX) {
833 if (o->op_private & OPpTARGET_MY)
834 sv_catpv(tmpsv, ",TARGET_MY");
836 else if (optype == OP_LEAVESUB ||
837 optype == OP_LEAVE ||
838 optype == OP_LEAVESUBLV ||
839 optype == OP_LEAVEWRITE) {
840 if (o->op_private & OPpREFCOUNTED)
841 sv_catpv(tmpsv, ",REFCOUNTED");
843 else if (optype == OP_AASSIGN) {
844 if (o->op_private & OPpASSIGN_COMMON)
845 sv_catpv(tmpsv, ",COMMON");
847 else if (optype == OP_SASSIGN) {
848 if (o->op_private & OPpASSIGN_BACKWARDS)
849 sv_catpv(tmpsv, ",BACKWARDS");
851 else if (optype == OP_TRANS) {
852 if (o->op_private & OPpTRANS_SQUASH)
853 sv_catpv(tmpsv, ",SQUASH");
854 if (o->op_private & OPpTRANS_DELETE)
855 sv_catpv(tmpsv, ",DELETE");
856 if (o->op_private & OPpTRANS_COMPLEMENT)
857 sv_catpv(tmpsv, ",COMPLEMENT");
858 if (o->op_private & OPpTRANS_IDENTICAL)
859 sv_catpv(tmpsv, ",IDENTICAL");
860 if (o->op_private & OPpTRANS_GROWS)
861 sv_catpv(tmpsv, ",GROWS");
863 else if (optype == OP_REPEAT) {
864 if (o->op_private & OPpREPEAT_DOLIST)
865 sv_catpv(tmpsv, ",DOLIST");
867 else if (optype == OP_ENTERSUB ||
868 optype == OP_RV2SV ||
870 optype == OP_RV2AV ||
871 optype == OP_RV2HV ||
872 optype == OP_RV2GV ||
873 optype == OP_AELEM ||
876 if (optype == OP_ENTERSUB) {
877 if (o->op_private & OPpENTERSUB_AMPER)
878 sv_catpv(tmpsv, ",AMPER");
879 if (o->op_private & OPpENTERSUB_DB)
880 sv_catpv(tmpsv, ",DB");
881 if (o->op_private & OPpENTERSUB_HASTARG)
882 sv_catpv(tmpsv, ",HASTARG");
883 if (o->op_private & OPpENTERSUB_NOPAREN)
884 sv_catpv(tmpsv, ",NOPAREN");
885 if (o->op_private & OPpENTERSUB_INARGS)
886 sv_catpv(tmpsv, ",INARGS");
887 if (o->op_private & OPpENTERSUB_NOMOD)
888 sv_catpv(tmpsv, ",NOMOD");
891 switch (o->op_private & OPpDEREF) {
893 sv_catpv(tmpsv, ",SV");
896 sv_catpv(tmpsv, ",AV");
899 sv_catpv(tmpsv, ",HV");
902 if (o->op_private & OPpMAYBE_LVSUB)
903 sv_catpv(tmpsv, ",MAYBE_LVSUB");
905 if (optype == OP_AELEM || optype == OP_HELEM) {
906 if (o->op_private & OPpLVAL_DEFER)
907 sv_catpv(tmpsv, ",LVAL_DEFER");
910 if (o->op_private & HINT_STRICT_REFS)
911 sv_catpv(tmpsv, ",STRICT_REFS");
912 if (o->op_private & OPpOUR_INTRO)
913 sv_catpv(tmpsv, ",OUR_INTRO");
916 else if (optype == OP_CONST) {
917 if (o->op_private & OPpCONST_BARE)
918 sv_catpv(tmpsv, ",BARE");
919 if (o->op_private & OPpCONST_STRICT)
920 sv_catpv(tmpsv, ",STRICT");
921 if (o->op_private & OPpCONST_ARYBASE)
922 sv_catpv(tmpsv, ",ARYBASE");
923 if (o->op_private & OPpCONST_WARNING)
924 sv_catpv(tmpsv, ",WARNING");
925 if (o->op_private & OPpCONST_ENTERED)
926 sv_catpv(tmpsv, ",ENTERED");
928 else if (optype == OP_FLIP) {
929 if (o->op_private & OPpFLIP_LINENUM)
930 sv_catpv(tmpsv, ",LINENUM");
932 else if (optype == OP_FLOP) {
933 if (o->op_private & OPpFLIP_LINENUM)
934 sv_catpv(tmpsv, ",LINENUM");
936 else if (optype == OP_RV2CV) {
937 if (o->op_private & OPpLVAL_INTRO)
938 sv_catpv(tmpsv, ",INTRO");
940 else if (optype == OP_GV) {
941 if (o->op_private & OPpEARLY_CV)
942 sv_catpv(tmpsv, ",EARLY_CV");
944 else if (optype == OP_LIST) {
945 if (o->op_private & OPpLIST_GUESSED)
946 sv_catpv(tmpsv, ",GUESSED");
948 else if (optype == OP_DELETE) {
949 if (o->op_private & OPpSLICE)
950 sv_catpv(tmpsv, ",SLICE");
952 else if (optype == OP_EXISTS) {
953 if (o->op_private & OPpEXISTS_SUB)
954 sv_catpv(tmpsv, ",EXISTS_SUB");
956 else if (optype == OP_SORT) {
957 if (o->op_private & OPpSORT_NUMERIC)
958 sv_catpv(tmpsv, ",NUMERIC");
959 if (o->op_private & OPpSORT_INTEGER)
960 sv_catpv(tmpsv, ",INTEGER");
961 if (o->op_private & OPpSORT_REVERSE)
962 sv_catpv(tmpsv, ",REVERSE");
964 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
965 if (o->op_private & OPpOPEN_IN_RAW)
966 sv_catpv(tmpsv, ",IN_RAW");
967 if (o->op_private & OPpOPEN_IN_CRLF)
968 sv_catpv(tmpsv, ",IN_CRLF");
969 if (o->op_private & OPpOPEN_OUT_RAW)
970 sv_catpv(tmpsv, ",OUT_RAW");
971 if (o->op_private & OPpOPEN_OUT_CRLF)
972 sv_catpv(tmpsv, ",OUT_CRLF");
974 else if (optype == OP_EXIT) {
975 if (o->op_private & OPpEXIT_VMSISH)
976 sv_catpv(tmpsv, ",EXIT_VMSISH");
977 if (o->op_private & OPpHUSH_VMSISH)
978 sv_catpv(tmpsv, ",HUSH_VMSISH");
980 else if (optype == OP_DIE) {
981 if (o->op_private & OPpHUSH_VMSISH)
982 sv_catpv(tmpsv, ",HUSH_VMSISH");
984 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
985 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
986 sv_catpv(tmpsv, ",FT_ACCESS");
987 if (o->op_private & OPpFT_STACKED)
988 sv_catpv(tmpsv, ",FT_STACKED");
990 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
991 sv_catpv(tmpsv, ",INTRO");
993 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
998 if (PL_madskills && o->op_madprop) {
999 SV * const tmpsv = newSVpvn("", 0);
1000 MADPROP* mp = o->op_madprop;
1001 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1004 const char tmp = mp->mad_key;
1005 sv_setpvn(tmpsv,"'",1);
1007 sv_catpvn(tmpsv, &tmp, 1);
1008 sv_catpv(tmpsv, "'=");
1009 switch (mp->mad_type) {
1011 sv_catpv(tmpsv, "NULL");
1012 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1015 sv_catpv(tmpsv, "<");
1016 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1017 sv_catpv(tmpsv, ">");
1018 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1021 if ((OP*)mp->mad_val) {
1022 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1023 do_op_dump(level, file, (OP*)mp->mad_val);
1027 sv_catpv(tmpsv, "(UNK)");
1028 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1034 Perl_dump_indent(aTHX_ level, file, "}\n");
1036 SvREFCNT_dec(tmpsv);
1045 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1047 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1048 if (cSVOPo->op_sv) {
1049 SV * const tmpsv = newSV(0);
1053 /* FIXME - is this making unwarranted assumptions about the
1054 UTF-8 cleanliness of the dump file handle? */
1057 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1058 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1059 SvPV_nolen_const(tmpsv));
1063 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 (cCOPo->cop_label)
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";
1266 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1268 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1271 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1274 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1278 const char *name = NULL;
1279 for (n = 0; magic_names[n].name; n++) {
1280 if (mg->mg_type == magic_names[n].type) {
1281 name = magic_names[n].name;
1286 Perl_dump_indent(aTHX_ level, file,
1287 " MG_TYPE = PERL_MAGIC_%s\n", name);
1289 Perl_dump_indent(aTHX_ level, file,
1290 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1294 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1295 if (mg->mg_type == PERL_MAGIC_envelem &&
1296 mg->mg_flags & MGf_TAINTEDDIR)
1297 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1298 if (mg->mg_flags & MGf_REFCOUNTED)
1299 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1300 if (mg->mg_flags & MGf_GSKIP)
1301 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1302 if (mg->mg_type == PERL_MAGIC_regex_global &&
1303 mg->mg_flags & MGf_MINMATCH)
1304 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1307 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1308 PTR2UV(mg->mg_obj));
1309 if (mg->mg_type == PERL_MAGIC_qr) {
1310 REGEXP* const re = (REGEXP *)mg->mg_obj;
1311 SV * const dsv = sv_newmortal();
1312 const char * const s
1313 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1315 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1316 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1318 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1319 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1322 if (mg->mg_flags & MGf_REFCOUNTED)
1323 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1326 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1328 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1329 if (mg->mg_len >= 0) {
1330 if (mg->mg_type != PERL_MAGIC_utf8) {
1331 SV * const sv = newSVpvs("");
1332 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1336 else if (mg->mg_len == HEf_SVKEY) {
1337 PerlIO_puts(file, " => HEf_SVKEY\n");
1338 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1342 PerlIO_puts(file, " ???? - please notify IZ");
1343 PerlIO_putc(file, '\n');
1345 if (mg->mg_type == PERL_MAGIC_utf8) {
1346 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1349 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1350 Perl_dump_indent(aTHX_ level, file,
1351 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1354 (UV)cache[i * 2 + 1]);
1361 Perl_magic_dump(pTHX_ const MAGIC *mg)
1363 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1367 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1371 PERL_ARGS_ASSERT_DO_HV_DUMP;
1373 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1374 if (sv && (hvname = HvNAME_get(sv)))
1375 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1377 PerlIO_putc(file, '\n');
1381 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1383 PERL_ARGS_ASSERT_DO_GV_DUMP;
1385 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1386 if (sv && GvNAME(sv))
1387 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1389 PerlIO_putc(file, '\n');
1393 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1395 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1397 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1398 if (sv && GvNAME(sv)) {
1400 PerlIO_printf(file, "\t\"");
1401 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1402 PerlIO_printf(file, "%s\" :: \"", hvname);
1403 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1406 PerlIO_putc(file, '\n');
1410 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1418 PERL_ARGS_ASSERT_DO_SV_DUMP;
1421 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1425 flags = SvFLAGS(sv);
1428 d = Perl_newSVpvf(aTHX_
1429 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1430 PTR2UV(SvANY(sv)), PTR2UV(sv),
1431 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1432 (int)(PL_dumpindent*level), "");
1434 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1435 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1437 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1438 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1439 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1441 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1442 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1443 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1444 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1445 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1447 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1448 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1449 if (flags & SVf_POK) sv_catpv(d, "POK,");
1450 if (flags & SVf_ROK) {
1451 sv_catpv(d, "ROK,");
1452 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1454 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1455 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1456 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1457 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1459 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1460 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1461 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1462 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1463 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1464 if (SvPCS_IMPORTED(sv))
1465 sv_catpv(d, "PCS_IMPORTED,");
1467 sv_catpv(d, "SCREAM,");
1473 if (CvANON(sv)) sv_catpv(d, "ANON,");
1474 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1475 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1476 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1477 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1478 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1479 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1480 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1481 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1482 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1483 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1486 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1487 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1488 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1489 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1490 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1494 if (isGV_with_GP(sv)) {
1495 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1496 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1497 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
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))
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)) {
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);
1666 sv_setpvn(d, "", 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((AV*)sv) >= 0) {
1673 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1674 SV** const elt = av_fetch((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);
1755 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1757 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1759 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1763 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1765 HV * const hv = (HV*)sv;
1766 int count = maxnest - nest;
1769 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1772 const U32 hash = HeHASH(he);
1773 SV * const keysv = hv_iterkeysv(he);
1774 const char * const keypv = SvPV_const(keysv, len);
1775 SV * const elt = hv_iterval(hv, he);
1777 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1779 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1781 PerlIO_printf(file, "[REHASH] ");
1782 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1783 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1785 hv_iterinit(hv); /* Return to status quo */
1791 const char *const proto = SvPV_const(sv, len);
1792 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1797 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1798 if (!CvISXSUB(sv)) {
1800 Perl_dump_indent(aTHX_ level, file,
1801 " START = 0x%"UVxf" ===> %"IVdf"\n",
1802 PTR2UV(CvSTART(sv)),
1803 (IV)sequence_num(CvSTART(sv)));
1805 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1806 PTR2UV(CvROOT(sv)));
1807 if (CvROOT(sv) && dumpops) {
1808 do_op_dump(level+1, file, CvROOT(sv));
1811 SV * const constant = cv_const_sv((CV *)sv);
1813 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1816 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1818 PTR2UV(CvXSUBANY(sv).any_ptr));
1819 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1822 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1823 (IV)CvXSUBANY(sv).any_i32);
1826 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1827 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1828 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1829 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1830 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1831 if (type == SVt_PVFM)
1832 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1833 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1834 if (nest < maxnest) {
1835 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1838 const CV * const outside = CvOUTSIDE(sv);
1839 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1842 : CvANON(outside) ? "ANON"
1843 : (outside == PL_main_cv) ? "MAIN"
1844 : CvUNIQUE(outside) ? "UNIQUE"
1845 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1847 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1848 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1852 if (type == SVt_PVLV) {
1853 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1854 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1855 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1856 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1857 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1858 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1862 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1863 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1864 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1865 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1867 if (!isGV_with_GP(sv))
1869 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1870 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1871 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1872 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1875 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1876 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1877 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1878 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1879 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1880 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1881 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1882 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1883 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1884 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1885 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1886 do_gv_dump (level, file, " EGV", GvEGV(sv));
1889 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1890 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1891 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1892 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1893 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1894 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1895 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1897 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1898 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1899 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1901 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1902 PTR2UV(IoTOP_GV(sv)));
1903 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1906 /* Source filters hide things that are not GVs in these three, so let's
1907 be careful out there. */
1909 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1910 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1911 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1913 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1914 PTR2UV(IoFMT_GV(sv)));
1915 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1918 if (IoBOTTOM_NAME(sv))
1919 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1920 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1921 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1923 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1924 PTR2UV(IoBOTTOM_GV(sv)));
1925 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1928 if (isPRINT(IoTYPE(sv)))
1929 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1931 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1932 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1939 Perl_sv_dump(pTHX_ SV *sv)
1943 PERL_ARGS_ASSERT_SV_DUMP;
1946 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1948 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1952 Perl_runops_debug(pTHX)
1956 if (ckWARN_d(WARN_DEBUGGING))
1957 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1961 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1965 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1966 PerlIO_printf(Perl_debug_log,
1967 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1968 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1969 PTR2UV(*PL_watchaddr));
1970 if (DEBUG_s_TEST_) {
1971 if (DEBUG_v_TEST_) {
1972 PerlIO_printf(Perl_debug_log, "\n");
1980 if (DEBUG_t_TEST_) debop(PL_op);
1981 if (DEBUG_P_TEST_) debprof(PL_op);
1983 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1984 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1991 Perl_debop(pTHX_ const OP *o)
1995 PERL_ARGS_ASSERT_DEBOP;
1997 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2000 Perl_deb(aTHX_ "%s", OP_NAME(o));
2001 switch (o->op_type) {
2003 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2008 SV * const sv = newSV(0);
2010 /* FIXME - is this making unwarranted assumptions about the
2011 UTF-8 cleanliness of the dump file handle? */
2014 gv_fullname3(sv, cGVOPo_gv, NULL);
2015 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2019 PerlIO_printf(Perl_debug_log, "(NULL)");
2025 /* print the lexical's name */
2026 CV * const cv = deb_curcv(cxstack_ix);
2029 AV * const padlist = CvPADLIST(cv);
2030 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
2031 sv = *av_fetch(comppad, o->op_targ, FALSE);
2035 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2037 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2043 PerlIO_printf(Perl_debug_log, "\n");
2048 S_deb_curcv(pTHX_ const I32 ix)
2051 const PERL_CONTEXT * const cx = &cxstack[ix];
2052 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2053 return cx->blk_sub.cv;
2054 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2056 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2061 return deb_curcv(ix - 1);
2065 Perl_watch(pTHX_ char **addr)
2069 PERL_ARGS_ASSERT_WATCH;
2071 PL_watchaddr = addr;
2073 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2074 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2078 S_debprof(pTHX_ const OP *o)
2082 PERL_ARGS_ASSERT_DEBPROF;
2084 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2086 if (!PL_profiledata)
2087 Newxz(PL_profiledata, MAXO, U32);
2088 ++PL_profiledata[o->op_type];
2092 Perl_debprofdump(pTHX)
2096 if (!PL_profiledata)
2098 for (i = 0; i < MAXO; i++) {
2099 if (PL_profiledata[i])
2100 PerlIO_printf(Perl_debug_log,
2101 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2108 * XML variants of most of the above routines
2112 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2116 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2118 PerlIO_printf(file, "\n ");
2119 va_start(args, pat);
2120 xmldump_vindent(level, file, pat, &args);
2126 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2129 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2130 va_start(args, pat);
2131 xmldump_vindent(level, file, pat, &args);
2136 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2138 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2140 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2141 PerlIO_vprintf(file, pat, *args);
2145 Perl_xmldump_all(pTHX)
2147 PerlIO_setlinebuf(PL_xmlfp);
2149 op_xmldump(PL_main_root);
2150 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2151 PerlIO_close(PL_xmlfp);
2156 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2161 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2163 if (!HvARRAY(stash))
2165 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2166 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2167 GV *gv = (GV*)HeVAL(entry);
2169 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2175 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2176 && (hv = GvHV(gv)) && hv != PL_defstash)
2177 xmldump_packsubs(hv); /* nested package */
2183 Perl_xmldump_sub(pTHX_ const GV *gv)
2185 SV * const sv = sv_newmortal();
2187 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2189 gv_fullname3(sv, gv, NULL);
2190 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2191 if (CvXSUB(GvCV(gv)))
2192 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2193 PTR2UV(CvXSUB(GvCV(gv))),
2194 (int)CvXSUBANY(GvCV(gv)).any_i32);
2195 else if (CvROOT(GvCV(gv)))
2196 op_xmldump(CvROOT(GvCV(gv)));
2198 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2202 Perl_xmldump_form(pTHX_ const GV *gv)
2204 SV * const sv = sv_newmortal();
2206 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2208 gv_fullname3(sv, gv, NULL);
2209 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2210 if (CvROOT(GvFORM(gv)))
2211 op_xmldump(CvROOT(GvFORM(gv)));
2213 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2217 Perl_xmldump_eval(pTHX)
2219 op_xmldump(PL_eval_root);
2223 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2225 PERL_ARGS_ASSERT_SV_CATXMLSV;
2226 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2230 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2233 const char * const e = pv + len;
2234 const char * const start = pv;
2238 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2240 sv_catpvn(dsv,"",0);
2241 dsvcur = SvCUR(dsv); /* in case we have to restart */
2246 c = utf8_to_uvchr((U8*)pv, &cl);
2248 SvCUR(dsv) = dsvcur;
2313 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2316 sv_catpvs(dsv, "<");
2319 sv_catpvs(dsv, ">");
2322 sv_catpvs(dsv, "&");
2325 sv_catpvs(dsv, """);
2329 if (c < 32 || c > 127) {
2330 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2333 const char string = (char) c;
2334 sv_catpvn(dsv, &string, 1);
2338 if ((c >= 0xD800 && c <= 0xDB7F) ||
2339 (c >= 0xDC00 && c <= 0xDFFF) ||
2340 (c >= 0xFFF0 && c <= 0xFFFF) ||
2342 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2344 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2357 Perl_sv_xmlpeek(pTHX_ SV *sv)
2359 SV * const t = sv_newmortal();
2363 PERL_ARGS_ASSERT_SV_XMLPEEK;
2366 sv_setpvn(t, "", 0);
2369 sv_catpv(t, "VOID=\"\"");
2372 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2373 sv_catpv(t, "WILD=\"\"");
2376 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2377 if (sv == &PL_sv_undef) {
2378 sv_catpv(t, "SV_UNDEF=\"1\"");
2379 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2380 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2384 else if (sv == &PL_sv_no) {
2385 sv_catpv(t, "SV_NO=\"1\"");
2386 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2387 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2388 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2389 SVp_POK|SVp_NOK)) &&
2394 else if (sv == &PL_sv_yes) {
2395 sv_catpv(t, "SV_YES=\"1\"");
2396 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2397 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2398 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2399 SVp_POK|SVp_NOK)) &&
2401 SvPVX(sv) && *SvPVX(sv) == '1' &&
2406 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2407 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2408 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2412 sv_catpv(t, " XXX=\"\" ");
2414 else if (SvREFCNT(sv) == 0) {
2415 sv_catpv(t, " refcnt=\"0\"");
2418 else if (DEBUG_R_TEST_) {
2421 /* is this SV on the tmps stack? */
2422 for (ix=PL_tmps_ix; ix>=0; ix--) {
2423 if (PL_tmps_stack[ix] == sv) {
2428 if (SvREFCNT(sv) > 1)
2429 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2432 sv_catpv(t, " DRT=\"<T>\"");
2436 sv_catpv(t, " ROK=\"\"");
2438 switch (SvTYPE(sv)) {
2440 sv_catpv(t, " FREED=\"1\"");
2444 sv_catpv(t, " UNDEF=\"1\"");
2447 sv_catpv(t, " IV=\"");
2450 sv_catpv(t, " NV=\"");
2453 sv_catpv(t, " PV=\"");
2456 sv_catpv(t, " PVIV=\"");
2459 sv_catpv(t, " PVNV=\"");
2462 sv_catpv(t, " PVMG=\"");
2465 sv_catpv(t, " PVLV=\"");
2468 sv_catpv(t, " AV=\"");
2471 sv_catpv(t, " HV=\"");
2475 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2477 sv_catpv(t, " CV=\"()\"");
2480 sv_catpv(t, " GV=\"");
2483 sv_catpv(t, " BIND=\"");
2486 sv_catpv(t, " ORANGE=\"");
2489 sv_catpv(t, " FM=\"");
2492 sv_catpv(t, " IO=\"");
2501 else if (SvNOKp(sv)) {
2502 STORE_NUMERIC_LOCAL_SET_STANDARD();
2503 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2504 RESTORE_NUMERIC_LOCAL();
2506 else if (SvIOKp(sv)) {
2508 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2510 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2519 return SvPV(t, n_a);
2523 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2525 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2528 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2531 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2534 REGEXP *const r = PM_GETRE(pm);
2535 SV * const tmpsv = newSVsv((SV*)r);
2536 sv_utf8_upgrade(tmpsv);
2537 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2539 SvREFCNT_dec(tmpsv);
2540 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2541 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2544 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2545 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2546 SV * const tmpsv = pm_description(pm);
2547 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2548 SvREFCNT_dec(tmpsv);
2552 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2553 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2554 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2555 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2556 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2557 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2560 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2564 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2566 do_pmop_xmldump(0, PL_xmlfp, pm);
2570 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2575 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2580 seq = sequence_num(o);
2581 Perl_xmldump_indent(aTHX_ level, file,
2582 "<op_%s seq=\"%"UVuf" -> ",
2587 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2588 sequence_num(o->op_next));
2590 PerlIO_printf(file, "DONE\"");
2593 if (o->op_type == OP_NULL)
2595 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2596 if (o->op_targ == OP_NEXTSTATE)
2599 PerlIO_printf(file, " line=\"%"UVuf"\"",
2600 (UV)CopLINE(cCOPo));
2601 if (CopSTASHPV(cCOPo))
2602 PerlIO_printf(file, " package=\"%s\"",
2604 if (cCOPo->cop_label)
2605 PerlIO_printf(file, " label=\"%s\"",
2610 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2613 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2616 SV * const tmpsv = newSVpvn("", 0);
2617 switch (o->op_flags & OPf_WANT) {
2619 sv_catpv(tmpsv, ",VOID");
2621 case OPf_WANT_SCALAR:
2622 sv_catpv(tmpsv, ",SCALAR");
2625 sv_catpv(tmpsv, ",LIST");
2628 sv_catpv(tmpsv, ",UNKNOWN");
2631 if (o->op_flags & OPf_KIDS)
2632 sv_catpv(tmpsv, ",KIDS");
2633 if (o->op_flags & OPf_PARENS)
2634 sv_catpv(tmpsv, ",PARENS");
2635 if (o->op_flags & OPf_STACKED)
2636 sv_catpv(tmpsv, ",STACKED");
2637 if (o->op_flags & OPf_REF)
2638 sv_catpv(tmpsv, ",REF");
2639 if (o->op_flags & OPf_MOD)
2640 sv_catpv(tmpsv, ",MOD");
2641 if (o->op_flags & OPf_SPECIAL)
2642 sv_catpv(tmpsv, ",SPECIAL");
2643 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2644 SvREFCNT_dec(tmpsv);
2646 if (o->op_private) {
2647 SV * const tmpsv = newSVpvn("", 0);
2648 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2649 if (o->op_private & OPpTARGET_MY)
2650 sv_catpv(tmpsv, ",TARGET_MY");
2652 else if (o->op_type == OP_LEAVESUB ||
2653 o->op_type == OP_LEAVE ||
2654 o->op_type == OP_LEAVESUBLV ||
2655 o->op_type == OP_LEAVEWRITE) {
2656 if (o->op_private & OPpREFCOUNTED)
2657 sv_catpv(tmpsv, ",REFCOUNTED");
2659 else if (o->op_type == OP_AASSIGN) {
2660 if (o->op_private & OPpASSIGN_COMMON)
2661 sv_catpv(tmpsv, ",COMMON");
2663 else if (o->op_type == OP_SASSIGN) {
2664 if (o->op_private & OPpASSIGN_BACKWARDS)
2665 sv_catpv(tmpsv, ",BACKWARDS");
2667 else if (o->op_type == OP_TRANS) {
2668 if (o->op_private & OPpTRANS_SQUASH)
2669 sv_catpv(tmpsv, ",SQUASH");
2670 if (o->op_private & OPpTRANS_DELETE)
2671 sv_catpv(tmpsv, ",DELETE");
2672 if (o->op_private & OPpTRANS_COMPLEMENT)
2673 sv_catpv(tmpsv, ",COMPLEMENT");
2674 if (o->op_private & OPpTRANS_IDENTICAL)
2675 sv_catpv(tmpsv, ",IDENTICAL");
2676 if (o->op_private & OPpTRANS_GROWS)
2677 sv_catpv(tmpsv, ",GROWS");
2679 else if (o->op_type == OP_REPEAT) {
2680 if (o->op_private & OPpREPEAT_DOLIST)
2681 sv_catpv(tmpsv, ",DOLIST");
2683 else if (o->op_type == OP_ENTERSUB ||
2684 o->op_type == OP_RV2SV ||
2685 o->op_type == OP_GVSV ||
2686 o->op_type == OP_RV2AV ||
2687 o->op_type == OP_RV2HV ||
2688 o->op_type == OP_RV2GV ||
2689 o->op_type == OP_AELEM ||
2690 o->op_type == OP_HELEM )
2692 if (o->op_type == OP_ENTERSUB) {
2693 if (o->op_private & OPpENTERSUB_AMPER)
2694 sv_catpv(tmpsv, ",AMPER");
2695 if (o->op_private & OPpENTERSUB_DB)
2696 sv_catpv(tmpsv, ",DB");
2697 if (o->op_private & OPpENTERSUB_HASTARG)
2698 sv_catpv(tmpsv, ",HASTARG");
2699 if (o->op_private & OPpENTERSUB_NOPAREN)
2700 sv_catpv(tmpsv, ",NOPAREN");
2701 if (o->op_private & OPpENTERSUB_INARGS)
2702 sv_catpv(tmpsv, ",INARGS");
2703 if (o->op_private & OPpENTERSUB_NOMOD)
2704 sv_catpv(tmpsv, ",NOMOD");
2707 switch (o->op_private & OPpDEREF) {
2709 sv_catpv(tmpsv, ",SV");
2712 sv_catpv(tmpsv, ",AV");
2715 sv_catpv(tmpsv, ",HV");
2718 if (o->op_private & OPpMAYBE_LVSUB)
2719 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2721 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2722 if (o->op_private & OPpLVAL_DEFER)
2723 sv_catpv(tmpsv, ",LVAL_DEFER");
2726 if (o->op_private & HINT_STRICT_REFS)
2727 sv_catpv(tmpsv, ",STRICT_REFS");
2728 if (o->op_private & OPpOUR_INTRO)
2729 sv_catpv(tmpsv, ",OUR_INTRO");
2732 else if (o->op_type == OP_CONST) {
2733 if (o->op_private & OPpCONST_BARE)
2734 sv_catpv(tmpsv, ",BARE");
2735 if (o->op_private & OPpCONST_STRICT)
2736 sv_catpv(tmpsv, ",STRICT");
2737 if (o->op_private & OPpCONST_ARYBASE)
2738 sv_catpv(tmpsv, ",ARYBASE");
2739 if (o->op_private & OPpCONST_WARNING)
2740 sv_catpv(tmpsv, ",WARNING");
2741 if (o->op_private & OPpCONST_ENTERED)
2742 sv_catpv(tmpsv, ",ENTERED");
2744 else if (o->op_type == OP_FLIP) {
2745 if (o->op_private & OPpFLIP_LINENUM)
2746 sv_catpv(tmpsv, ",LINENUM");
2748 else if (o->op_type == OP_FLOP) {
2749 if (o->op_private & OPpFLIP_LINENUM)
2750 sv_catpv(tmpsv, ",LINENUM");
2752 else if (o->op_type == OP_RV2CV) {
2753 if (o->op_private & OPpLVAL_INTRO)
2754 sv_catpv(tmpsv, ",INTRO");
2756 else if (o->op_type == OP_GV) {
2757 if (o->op_private & OPpEARLY_CV)
2758 sv_catpv(tmpsv, ",EARLY_CV");
2760 else if (o->op_type == OP_LIST) {
2761 if (o->op_private & OPpLIST_GUESSED)
2762 sv_catpv(tmpsv, ",GUESSED");
2764 else if (o->op_type == OP_DELETE) {
2765 if (o->op_private & OPpSLICE)
2766 sv_catpv(tmpsv, ",SLICE");
2768 else if (o->op_type == OP_EXISTS) {
2769 if (o->op_private & OPpEXISTS_SUB)
2770 sv_catpv(tmpsv, ",EXISTS_SUB");
2772 else if (o->op_type == OP_SORT) {
2773 if (o->op_private & OPpSORT_NUMERIC)
2774 sv_catpv(tmpsv, ",NUMERIC");
2775 if (o->op_private & OPpSORT_INTEGER)
2776 sv_catpv(tmpsv, ",INTEGER");
2777 if (o->op_private & OPpSORT_REVERSE)
2778 sv_catpv(tmpsv, ",REVERSE");
2780 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2781 if (o->op_private & OPpOPEN_IN_RAW)
2782 sv_catpv(tmpsv, ",IN_RAW");
2783 if (o->op_private & OPpOPEN_IN_CRLF)
2784 sv_catpv(tmpsv, ",IN_CRLF");
2785 if (o->op_private & OPpOPEN_OUT_RAW)
2786 sv_catpv(tmpsv, ",OUT_RAW");
2787 if (o->op_private & OPpOPEN_OUT_CRLF)
2788 sv_catpv(tmpsv, ",OUT_CRLF");
2790 else if (o->op_type == OP_EXIT) {
2791 if (o->op_private & OPpEXIT_VMSISH)
2792 sv_catpv(tmpsv, ",EXIT_VMSISH");
2793 if (o->op_private & OPpHUSH_VMSISH)
2794 sv_catpv(tmpsv, ",HUSH_VMSISH");
2796 else if (o->op_type == OP_DIE) {
2797 if (o->op_private & OPpHUSH_VMSISH)
2798 sv_catpv(tmpsv, ",HUSH_VMSISH");
2800 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2801 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2802 sv_catpv(tmpsv, ",FT_ACCESS");
2803 if (o->op_private & OPpFT_STACKED)
2804 sv_catpv(tmpsv, ",FT_STACKED");
2806 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2807 sv_catpv(tmpsv, ",INTRO");
2809 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2810 SvREFCNT_dec(tmpsv);
2813 switch (o->op_type) {
2815 if (o->op_flags & OPf_SPECIAL) {
2821 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2823 if (cSVOPo->op_sv) {
2824 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2825 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2831 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
2832 s = SvPV(tmpsv1,len);
2833 sv_catxmlpvn(tmpsv2, s, len, 1);
2834 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2838 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2842 case OP_METHOD_NAMED:
2843 #ifndef USE_ITHREADS
2844 /* with ITHREADS, consts are stored in the pad, and the right pad
2845 * may not be active here, so skip */
2846 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2852 PerlIO_printf(file, ">\n");
2854 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2859 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2860 (UV)CopLINE(cCOPo));
2861 if (CopSTASHPV(cCOPo))
2862 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2864 if (cCOPo->cop_label)
2865 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2869 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2870 if (cLOOPo->op_redoop)
2871 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2873 PerlIO_printf(file, "DONE\"");
2874 S_xmldump_attr(aTHX_ level, file, "next=\"");
2875 if (cLOOPo->op_nextop)
2876 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2878 PerlIO_printf(file, "DONE\"");
2879 S_xmldump_attr(aTHX_ level, file, "last=\"");
2880 if (cLOOPo->op_lastop)
2881 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2883 PerlIO_printf(file, "DONE\"");
2891 S_xmldump_attr(aTHX_ level, file, "other=\"");
2892 if (cLOGOPo->op_other)
2893 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2895 PerlIO_printf(file, "DONE\"");
2903 if (o->op_private & OPpREFCOUNTED)
2904 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2910 if (PL_madskills && o->op_madprop) {
2911 char prevkey = '\0';
2912 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2913 const MADPROP* mp = o->op_madprop;
2917 PerlIO_printf(file, ">\n");
2919 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2922 char tmp = mp->mad_key;
2923 sv_setpvn(tmpsv,"\"",1);
2925 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2926 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2927 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2930 sv_catpv(tmpsv, "\"");
2931 switch (mp->mad_type) {
2933 sv_catpv(tmpsv, "NULL");
2934 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2937 sv_catpv(tmpsv, " val=\"");
2938 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2939 sv_catpv(tmpsv, "\"");
2940 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2943 sv_catpv(tmpsv, " val=\"");
2944 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2945 sv_catpv(tmpsv, "\"");
2946 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2949 if ((OP*)mp->mad_val) {
2950 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2951 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2952 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2956 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2962 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2964 SvREFCNT_dec(tmpsv);
2967 switch (o->op_type) {
2974 PerlIO_printf(file, ">\n");
2976 do_pmop_xmldump(level, file, cPMOPo);
2982 if (o->op_flags & OPf_KIDS) {
2986 PerlIO_printf(file, ">\n");
2988 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2989 do_op_xmldump(level, file, kid);
2993 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2995 PerlIO_printf(file, " />\n");
2999 Perl_op_xmldump(pTHX_ const OP *o)
3001 PERL_ARGS_ASSERT_OP_XMLDUMP;
3003 do_op_xmldump(0, PL_xmlfp, o);
3009 * c-indentation-style: bsd
3011 * indent-tabs-mode: t
3014 * ex: set ts=8 sts=4 sw=4 noet: