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, ...)
76 dump_vindent(level, file, pat, &args);
81 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
84 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
85 PerlIO_vprintf(file, pat, *args);
92 PerlIO_setlinebuf(Perl_debug_log);
94 op_dump(PL_main_root);
95 dump_packsubs(PL_defstash);
99 Perl_dump_packsubs(pTHX_ const HV *stash)
106 for (i = 0; i <= (I32) HvMAX(stash); i++) {
108 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
109 const GV * const gv = (GV*)HeVAL(entry);
110 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
116 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
117 const HV * const hv = GvHV(gv);
118 if (hv && (hv != PL_defstash))
119 dump_packsubs(hv); /* nested package */
126 Perl_dump_sub(pTHX_ const GV *gv)
128 SV * const sv = sv_newmortal();
130 gv_fullname3(sv, gv, NULL);
131 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
132 if (CvISXSUB(GvCV(gv)))
133 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
134 PTR2UV(CvXSUB(GvCV(gv))),
135 (int)CvXSUBANY(GvCV(gv)).any_i32);
136 else if (CvROOT(GvCV(gv)))
137 op_dump(CvROOT(GvCV(gv)));
139 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
143 Perl_dump_form(pTHX_ const GV *gv)
145 SV * const sv = sv_newmortal();
147 gv_fullname3(sv, gv, NULL);
148 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
149 if (CvROOT(GvFORM(gv)))
150 op_dump(CvROOT(GvFORM(gv)));
152 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
159 op_dump(PL_eval_root);
164 =for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\
165 |const STRLEN count|const STRLEN max
166 |STRLEN const *escaped, const U32 flags
168 Escapes at most the first "count" chars of pv and puts the results into
169 dsv such that the size of the escaped string will not exceed "max" chars
170 and will not contain any incomplete escape sequences.
172 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
173 will also be escaped.
175 Normally the SV will be cleared before the escaped string is prepared,
176 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
178 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
179 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
180 using C<is_utf8_string()> to determine if it is Unicode.
182 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
183 using C<\x01F1> style escapes, otherwise only chars above 255 will be
184 escaped using this style, other non printable chars will use octal or
185 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
186 then all chars below 255 will be treated as printable and
187 will be output as literals.
189 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
190 string will be escaped, regardles of max. If the string is utf8 and
191 the chars value is >255 then it will be returned as a plain hex
192 sequence. Thus the output will either be a single char,
193 an octal escape sequence, a special escape like C<\n> or a 3 or
194 more digit hex value.
196 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
197 not a '\\'. This is because regexes very often contain backslashed
198 sequences, whereas '%' is not a particularly common character in patterns.
200 Returns a pointer to the escaped text as held by dsv.
204 #define PV_ESCAPE_OCTBUFSIZE 32
207 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
208 const STRLEN count, const STRLEN max,
209 STRLEN * const escaped, const U32 flags )
211 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
212 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
213 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
214 STRLEN wrote = 0; /* chars written so far */
215 STRLEN chsize = 0; /* size of data to be written */
216 STRLEN readsize = 1; /* size of data just read */
217 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
218 const char *pv = str;
219 const char * const end = pv + count; /* end of string */
222 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
223 /* This won't alter the UTF-8 flag */
224 sv_setpvn(dsv, "", 0);
227 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
230 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
231 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
232 const U8 c = (U8)u & 0xFF;
234 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
235 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
236 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
239 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
240 "%cx{%"UVxf"}", esc, u);
241 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
244 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
248 case '\\' : /* fallthrough */
249 case '%' : if ( c == esc ) {
255 case '\v' : octbuf[1] = 'v'; break;
256 case '\t' : octbuf[1] = 't'; break;
257 case '\r' : octbuf[1] = 'r'; break;
258 case '\n' : octbuf[1] = 'n'; break;
259 case '\f' : octbuf[1] = 'f'; break;
267 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
268 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
271 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
278 if ( max && (wrote + chsize > max) ) {
280 } else if (chsize > 1) {
281 sv_catpvn(dsv, octbuf, chsize);
284 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
285 128-255 can be appended raw to the dsv. If dsv happens to be
286 UTF-8 then we need catpvf to upgrade them for us.
287 Or add a new API call sv_catpvc(). Think about that name, and
288 how to keep it clear that it's unlike the s of catpvs, which is
289 really an array octets, not a string. */
290 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
293 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
301 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
302 |const STRLEN count|const STRLEN max\
303 |const char const *start_color| const char const *end_color\
306 Converts a string into something presentable, handling escaping via
307 pv_escape() and supporting quoting and ellipses.
309 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
310 double quoted with any double quotes in the string escaped. Otherwise
311 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
314 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
315 string were output then an ellipsis C<...> will be appended to the
316 string. Note that this happens AFTER it has been quoted.
318 If start_color is non-null then it will be inserted after the opening
319 quote (if there is one) but before the escaped text. If end_color
320 is non-null then it will be inserted after the escaped text but before
321 any quotes or ellipses.
323 Returns a pointer to the prettified text as held by dsv.
329 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
330 const STRLEN max, char const * const start_color, char const * const end_color,
333 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
336 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
337 /* This won't alter the UTF-8 flag */
338 sv_setpvn(dsv, "", 0);
342 sv_catpvn(dsv, "\"", 1);
343 else if ( flags & PERL_PV_PRETTY_LTGT )
344 sv_catpvn(dsv, "<", 1);
346 if ( start_color != NULL )
347 Perl_sv_catpv( aTHX_ dsv, start_color);
349 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
351 if ( end_color != NULL )
352 Perl_sv_catpv( aTHX_ dsv, end_color);
355 sv_catpvn( dsv, "\"", 1 );
356 else if ( flags & PERL_PV_PRETTY_LTGT )
357 sv_catpvn( dsv, ">", 1);
359 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
360 sv_catpvn( dsv, "...", 3 );
366 =for apidoc pv_display
368 char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
369 STRLEN pvlim, U32 flags)
373 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
375 except that an additional "\0" will be appended to the string when
376 len > cur and pv[cur] is "\0".
378 Note that the final string may be up to 7 chars longer than pvlim.
384 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
386 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
387 if (len > cur && pv[cur] == '\0')
388 sv_catpvn( dsv, "\\0", 2 );
393 Perl_sv_peek(pTHX_ SV *sv)
396 SV * const t = sv_newmortal();
406 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
410 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
411 if (sv == &PL_sv_undef) {
412 sv_catpv(t, "SV_UNDEF");
413 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
414 SVs_GMG|SVs_SMG|SVs_RMG)) &&
418 else if (sv == &PL_sv_no) {
419 sv_catpv(t, "SV_NO");
420 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
421 SVs_GMG|SVs_SMG|SVs_RMG)) &&
422 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
428 else if (sv == &PL_sv_yes) {
429 sv_catpv(t, "SV_YES");
430 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
431 SVs_GMG|SVs_SMG|SVs_RMG)) &&
432 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
435 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
440 sv_catpv(t, "SV_PLACEHOLDER");
441 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
442 SVs_GMG|SVs_SMG|SVs_RMG)) &&
448 else if (SvREFCNT(sv) == 0) {
452 else if (DEBUG_R_TEST_) {
455 /* is this SV on the tmps stack? */
456 for (ix=PL_tmps_ix; ix>=0; ix--) {
457 if (PL_tmps_stack[ix] == sv) {
462 if (SvREFCNT(sv) > 1)
463 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
471 if (SvCUR(t) + unref > 10) {
472 SvCUR_set(t, unref + 3);
481 if (type == SVt_PVCV) {
482 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
484 } else if (type < SVt_LAST) {
485 sv_catpv(t, svshorttypenames[type]);
487 if (type == SVt_NULL)
490 sv_catpv(t, "FREED");
495 if (!SvPVX_const(sv))
496 sv_catpv(t, "(null)");
498 SV * const tmp = newSVpvs("");
501 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
502 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
504 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
505 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
510 else if (SvNOKp(sv)) {
511 STORE_NUMERIC_LOCAL_SET_STANDARD();
512 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
513 RESTORE_NUMERIC_LOCAL();
515 else if (SvIOKp(sv)) {
517 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
519 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
527 return SvPV_nolen(t);
531 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
536 Perl_dump_indent(aTHX_ level, file, "{}\n");
539 Perl_dump_indent(aTHX_ level, file, "{\n");
541 if (pm->op_pmflags & PMf_ONCE)
546 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
547 ch, PM_GETRE(pm)->precomp, ch,
548 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
550 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
551 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
552 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
553 op_dump(pm->op_pmreplrootu.op_pmreplroot);
555 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
556 SV * const tmpsv = pm_description(pm);
557 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
561 Perl_dump_indent(aTHX_ level-1, file, "}\n");
565 S_pm_description(pTHX_ const PMOP *pm)
567 SV * const desc = newSVpvs("");
568 const REGEXP * const regex = PM_GETRE(pm);
569 const U32 pmflags = pm->op_pmflags;
571 if (pmflags & PMf_ONCE)
572 sv_catpv(desc, ",ONCE");
574 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
575 sv_catpv(desc, ":USED");
577 if (pmflags & PMf_USED)
578 sv_catpv(desc, ":USED");
582 if (regex->extflags & RXf_TAINTED)
583 sv_catpv(desc, ",TAINTED");
584 if (regex->check_substr) {
585 if (!(regex->extflags & RXf_NOSCAN))
586 sv_catpv(desc, ",SCANFIRST");
587 if (regex->extflags & RXf_CHECK_ALL)
588 sv_catpv(desc, ",ALL");
590 if (regex->extflags & RXf_SKIPWHITE)
591 sv_catpv(desc, ",SKIPWHITE");
594 if (pmflags & PMf_CONST)
595 sv_catpv(desc, ",CONST");
596 if (pmflags & PMf_KEEP)
597 sv_catpv(desc, ",KEEP");
598 if (pmflags & PMf_GLOBAL)
599 sv_catpv(desc, ",GLOBAL");
600 if (pmflags & PMf_CONTINUE)
601 sv_catpv(desc, ",CONTINUE");
602 if (pmflags & PMf_RETAINT)
603 sv_catpv(desc, ",RETAINT");
604 if (pmflags & PMf_EVAL)
605 sv_catpv(desc, ",EVAL");
610 Perl_pmop_dump(pTHX_ PMOP *pm)
612 do_pmop_dump(0, Perl_debug_log, pm);
615 /* An op sequencer. We visit the ops in the order they're to execute. */
618 S_sequence(pTHX_ register const OP *o)
621 const OP *oldop = NULL;
634 for (; o; o = o->op_next) {
636 SV * const op = newSVuv(PTR2UV(o));
637 const char * const key = SvPV_const(op, len);
639 if (hv_exists(Sequence, key, len))
642 switch (o->op_type) {
644 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
645 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
654 if (oldop && o->op_next)
661 if (oldop && o->op_next)
663 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
676 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
677 sequence_tail(cLOGOPo->op_other);
682 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
683 sequence_tail(cLOOPo->op_redoop);
684 sequence_tail(cLOOPo->op_nextop);
685 sequence_tail(cLOOPo->op_lastop);
689 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
690 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
699 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
707 S_sequence_tail(pTHX_ const OP *o)
709 while (o && (o->op_type == OP_NULL))
715 S_sequence_num(pTHX_ const OP *o)
723 op = newSVuv(PTR2UV(o));
724 key = SvPV_const(op, len);
725 seq = hv_fetch(Sequence, key, len, 0);
726 return seq ? SvUV(*seq): 0;
730 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
734 const OPCODE optype = o->op_type;
737 Perl_dump_indent(aTHX_ level, file, "{\n");
739 seq = sequence_num(o);
741 PerlIO_printf(file, "%-4"UVuf, seq);
743 PerlIO_printf(file, " ");
745 "%*sTYPE = %s ===> ",
746 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
748 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
749 sequence_num(o->op_next));
751 PerlIO_printf(file, "DONE\n");
753 if (optype == OP_NULL) {
754 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
755 if (o->op_targ == OP_NEXTSTATE) {
757 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
759 if (CopSTASHPV(cCOPo))
760 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
762 if (cCOPo->cop_label)
763 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
768 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
771 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
773 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
774 SV * const tmpsv = newSVpvs("");
775 switch (o->op_flags & OPf_WANT) {
777 sv_catpv(tmpsv, ",VOID");
779 case OPf_WANT_SCALAR:
780 sv_catpv(tmpsv, ",SCALAR");
783 sv_catpv(tmpsv, ",LIST");
786 sv_catpv(tmpsv, ",UNKNOWN");
789 if (o->op_flags & OPf_KIDS)
790 sv_catpv(tmpsv, ",KIDS");
791 if (o->op_flags & OPf_PARENS)
792 sv_catpv(tmpsv, ",PARENS");
793 if (o->op_flags & OPf_STACKED)
794 sv_catpv(tmpsv, ",STACKED");
795 if (o->op_flags & OPf_REF)
796 sv_catpv(tmpsv, ",REF");
797 if (o->op_flags & OPf_MOD)
798 sv_catpv(tmpsv, ",MOD");
799 if (o->op_flags & OPf_SPECIAL)
800 sv_catpv(tmpsv, ",SPECIAL");
802 sv_catpv(tmpsv, ",LATEFREE");
804 sv_catpv(tmpsv, ",LATEFREED");
806 sv_catpv(tmpsv, ",ATTACHED");
807 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
811 SV * const tmpsv = newSVpvs("");
812 if (PL_opargs[optype] & OA_TARGLEX) {
813 if (o->op_private & OPpTARGET_MY)
814 sv_catpv(tmpsv, ",TARGET_MY");
816 else if (optype == OP_LEAVESUB ||
817 optype == OP_LEAVE ||
818 optype == OP_LEAVESUBLV ||
819 optype == OP_LEAVEWRITE) {
820 if (o->op_private & OPpREFCOUNTED)
821 sv_catpv(tmpsv, ",REFCOUNTED");
823 else if (optype == OP_AASSIGN) {
824 if (o->op_private & OPpASSIGN_COMMON)
825 sv_catpv(tmpsv, ",COMMON");
827 else if (optype == OP_SASSIGN) {
828 if (o->op_private & OPpASSIGN_BACKWARDS)
829 sv_catpv(tmpsv, ",BACKWARDS");
831 else if (optype == OP_TRANS) {
832 if (o->op_private & OPpTRANS_SQUASH)
833 sv_catpv(tmpsv, ",SQUASH");
834 if (o->op_private & OPpTRANS_DELETE)
835 sv_catpv(tmpsv, ",DELETE");
836 if (o->op_private & OPpTRANS_COMPLEMENT)
837 sv_catpv(tmpsv, ",COMPLEMENT");
838 if (o->op_private & OPpTRANS_IDENTICAL)
839 sv_catpv(tmpsv, ",IDENTICAL");
840 if (o->op_private & OPpTRANS_GROWS)
841 sv_catpv(tmpsv, ",GROWS");
843 else if (optype == OP_REPEAT) {
844 if (o->op_private & OPpREPEAT_DOLIST)
845 sv_catpv(tmpsv, ",DOLIST");
847 else if (optype == OP_ENTERSUB ||
848 optype == OP_RV2SV ||
850 optype == OP_RV2AV ||
851 optype == OP_RV2HV ||
852 optype == OP_RV2GV ||
853 optype == OP_AELEM ||
856 if (optype == OP_ENTERSUB) {
857 if (o->op_private & OPpENTERSUB_AMPER)
858 sv_catpv(tmpsv, ",AMPER");
859 if (o->op_private & OPpENTERSUB_DB)
860 sv_catpv(tmpsv, ",DB");
861 if (o->op_private & OPpENTERSUB_HASTARG)
862 sv_catpv(tmpsv, ",HASTARG");
863 if (o->op_private & OPpENTERSUB_NOPAREN)
864 sv_catpv(tmpsv, ",NOPAREN");
865 if (o->op_private & OPpENTERSUB_INARGS)
866 sv_catpv(tmpsv, ",INARGS");
867 if (o->op_private & OPpENTERSUB_NOMOD)
868 sv_catpv(tmpsv, ",NOMOD");
871 switch (o->op_private & OPpDEREF) {
873 sv_catpv(tmpsv, ",SV");
876 sv_catpv(tmpsv, ",AV");
879 sv_catpv(tmpsv, ",HV");
882 if (o->op_private & OPpMAYBE_LVSUB)
883 sv_catpv(tmpsv, ",MAYBE_LVSUB");
885 if (optype == OP_AELEM || optype == OP_HELEM) {
886 if (o->op_private & OPpLVAL_DEFER)
887 sv_catpv(tmpsv, ",LVAL_DEFER");
890 if (o->op_private & HINT_STRICT_REFS)
891 sv_catpv(tmpsv, ",STRICT_REFS");
892 if (o->op_private & OPpOUR_INTRO)
893 sv_catpv(tmpsv, ",OUR_INTRO");
896 else if (optype == OP_CONST) {
897 if (o->op_private & OPpCONST_BARE)
898 sv_catpv(tmpsv, ",BARE");
899 if (o->op_private & OPpCONST_STRICT)
900 sv_catpv(tmpsv, ",STRICT");
901 if (o->op_private & OPpCONST_ARYBASE)
902 sv_catpv(tmpsv, ",ARYBASE");
903 if (o->op_private & OPpCONST_WARNING)
904 sv_catpv(tmpsv, ",WARNING");
905 if (o->op_private & OPpCONST_ENTERED)
906 sv_catpv(tmpsv, ",ENTERED");
908 else if (optype == OP_FLIP) {
909 if (o->op_private & OPpFLIP_LINENUM)
910 sv_catpv(tmpsv, ",LINENUM");
912 else if (optype == OP_FLOP) {
913 if (o->op_private & OPpFLIP_LINENUM)
914 sv_catpv(tmpsv, ",LINENUM");
916 else if (optype == OP_RV2CV) {
917 if (o->op_private & OPpLVAL_INTRO)
918 sv_catpv(tmpsv, ",INTRO");
920 else if (optype == OP_GV) {
921 if (o->op_private & OPpEARLY_CV)
922 sv_catpv(tmpsv, ",EARLY_CV");
924 else if (optype == OP_LIST) {
925 if (o->op_private & OPpLIST_GUESSED)
926 sv_catpv(tmpsv, ",GUESSED");
928 else if (optype == OP_DELETE) {
929 if (o->op_private & OPpSLICE)
930 sv_catpv(tmpsv, ",SLICE");
932 else if (optype == OP_EXISTS) {
933 if (o->op_private & OPpEXISTS_SUB)
934 sv_catpv(tmpsv, ",EXISTS_SUB");
936 else if (optype == OP_SORT) {
937 if (o->op_private & OPpSORT_NUMERIC)
938 sv_catpv(tmpsv, ",NUMERIC");
939 if (o->op_private & OPpSORT_INTEGER)
940 sv_catpv(tmpsv, ",INTEGER");
941 if (o->op_private & OPpSORT_REVERSE)
942 sv_catpv(tmpsv, ",REVERSE");
944 else if (optype == OP_OPEN || optype == OP_BACKTICK) {
945 if (o->op_private & OPpOPEN_IN_RAW)
946 sv_catpv(tmpsv, ",IN_RAW");
947 if (o->op_private & OPpOPEN_IN_CRLF)
948 sv_catpv(tmpsv, ",IN_CRLF");
949 if (o->op_private & OPpOPEN_OUT_RAW)
950 sv_catpv(tmpsv, ",OUT_RAW");
951 if (o->op_private & OPpOPEN_OUT_CRLF)
952 sv_catpv(tmpsv, ",OUT_CRLF");
954 else if (optype == OP_EXIT) {
955 if (o->op_private & OPpEXIT_VMSISH)
956 sv_catpv(tmpsv, ",EXIT_VMSISH");
957 if (o->op_private & OPpHUSH_VMSISH)
958 sv_catpv(tmpsv, ",HUSH_VMSISH");
960 else if (optype == OP_DIE) {
961 if (o->op_private & OPpHUSH_VMSISH)
962 sv_catpv(tmpsv, ",HUSH_VMSISH");
964 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
965 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
966 sv_catpv(tmpsv, ",FT_ACCESS");
967 if (o->op_private & OPpFT_STACKED)
968 sv_catpv(tmpsv, ",FT_STACKED");
970 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
971 sv_catpv(tmpsv, ",INTRO");
973 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
978 if (PL_madskills && o->op_madprop) {
979 SV * const tmpsv = newSVpvn("", 0);
980 MADPROP* mp = o->op_madprop;
981 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
984 const char tmp = mp->mad_key;
985 sv_setpvn(tmpsv,"'",1);
987 sv_catpvn(tmpsv, &tmp, 1);
988 sv_catpv(tmpsv, "'=");
989 switch (mp->mad_type) {
991 sv_catpv(tmpsv, "NULL");
992 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
995 sv_catpv(tmpsv, "<");
996 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
997 sv_catpv(tmpsv, ">");
998 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1001 if ((OP*)mp->mad_val) {
1002 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1003 do_op_dump(level, file, (OP*)mp->mad_val);
1007 sv_catpv(tmpsv, "(UNK)");
1008 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1014 Perl_dump_indent(aTHX_ level, file, "}\n");
1016 SvREFCNT_dec(tmpsv);
1025 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1027 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
1028 if (cSVOPo->op_sv) {
1029 SV * const tmpsv = newSV(0);
1033 /* FIXME - is this making unwarranted assumptions about the
1034 UTF-8 cleanliness of the dump file handle? */
1037 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
1038 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1039 SvPV_nolen_const(tmpsv));
1043 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1048 case OP_METHOD_NAMED:
1049 #ifndef USE_ITHREADS
1050 /* with ITHREADS, consts are stored in the pad, and the right pad
1051 * may not be active here, so skip */
1052 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1059 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1060 (UV)CopLINE(cCOPo));
1061 if (CopSTASHPV(cCOPo))
1062 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1064 if (cCOPo->cop_label)
1065 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1069 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1070 if (cLOOPo->op_redoop)
1071 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1073 PerlIO_printf(file, "DONE\n");
1074 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1075 if (cLOOPo->op_nextop)
1076 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1078 PerlIO_printf(file, "DONE\n");
1079 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1080 if (cLOOPo->op_lastop)
1081 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1083 PerlIO_printf(file, "DONE\n");
1091 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1092 if (cLOGOPo->op_other)
1093 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1095 PerlIO_printf(file, "DONE\n");
1101 do_pmop_dump(level, file, cPMOPo);
1109 if (o->op_private & OPpREFCOUNTED)
1110 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1115 if (o->op_flags & OPf_KIDS) {
1117 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1118 do_op_dump(level, file, kid);
1120 Perl_dump_indent(aTHX_ level-1, file, "}\n");
1124 Perl_op_dump(pTHX_ const OP *o)
1126 do_op_dump(0, Perl_debug_log, o);
1130 Perl_gv_dump(pTHX_ GV *gv)
1135 PerlIO_printf(Perl_debug_log, "{}\n");
1138 sv = sv_newmortal();
1139 PerlIO_printf(Perl_debug_log, "{\n");
1140 gv_fullname3(sv, gv, NULL);
1141 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1142 if (gv != GvEGV(gv)) {
1143 gv_efullname3(sv, GvEGV(gv), NULL);
1144 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1146 PerlIO_putc(Perl_debug_log, '\n');
1147 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1151 /* map magic types to the symbolic names
1152 * (with the PERL_MAGIC_ prefixed stripped)
1155 static const struct { const char type; const char *name; } magic_names[] = {
1156 { PERL_MAGIC_sv, "sv(\\0)" },
1157 { PERL_MAGIC_arylen, "arylen(#)" },
1158 { PERL_MAGIC_rhash, "rhash(%)" },
1159 { PERL_MAGIC_pos, "pos(.)" },
1160 { PERL_MAGIC_symtab, "symtab(:)" },
1161 { PERL_MAGIC_backref, "backref(<)" },
1162 { PERL_MAGIC_arylen_p, "arylen_p(@)" },
1163 { PERL_MAGIC_overload, "overload(A)" },
1164 { PERL_MAGIC_bm, "bm(B)" },
1165 { PERL_MAGIC_regdata, "regdata(D)" },
1166 { PERL_MAGIC_env, "env(E)" },
1167 { PERL_MAGIC_hints, "hints(H)" },
1168 { PERL_MAGIC_isa, "isa(I)" },
1169 { PERL_MAGIC_dbfile, "dbfile(L)" },
1170 { PERL_MAGIC_shared, "shared(N)" },
1171 { PERL_MAGIC_tied, "tied(P)" },
1172 { PERL_MAGIC_sig, "sig(S)" },
1173 { PERL_MAGIC_uvar, "uvar(U)" },
1174 { PERL_MAGIC_overload_elem, "overload_elem(a)" },
1175 { PERL_MAGIC_overload_table, "overload_table(c)" },
1176 { PERL_MAGIC_regdatum, "regdatum(d)" },
1177 { PERL_MAGIC_envelem, "envelem(e)" },
1178 { PERL_MAGIC_fm, "fm(f)" },
1179 { PERL_MAGIC_regex_global, "regex_global(g)" },
1180 { PERL_MAGIC_hintselem, "hintselem(h)" },
1181 { PERL_MAGIC_isaelem, "isaelem(i)" },
1182 { PERL_MAGIC_nkeys, "nkeys(k)" },
1183 { PERL_MAGIC_dbline, "dbline(l)" },
1184 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" },
1185 { PERL_MAGIC_collxfrm, "collxfrm(o)" },
1186 { PERL_MAGIC_tiedelem, "tiedelem(p)" },
1187 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" },
1188 { PERL_MAGIC_qr, "qr(r)" },
1189 { PERL_MAGIC_sigelem, "sigelem(s)" },
1190 { PERL_MAGIC_taint, "taint(t)" },
1191 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" },
1192 { PERL_MAGIC_vec, "vec(v)" },
1193 { PERL_MAGIC_vstring, "vstring(V)" },
1194 { PERL_MAGIC_utf8, "utf8(w)" },
1195 { PERL_MAGIC_substr, "substr(x)" },
1196 { PERL_MAGIC_defelem, "defelem(y)" },
1197 { PERL_MAGIC_ext, "ext(~)" },
1198 /* this null string terminates the list */
1203 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1205 for (; mg; mg = mg->mg_moremagic) {
1206 Perl_dump_indent(aTHX_ level, file,
1207 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1208 if (mg->mg_virtual) {
1209 const MGVTBL * const v = mg->mg_virtual;
1211 if (v == &PL_vtbl_sv) s = "sv";
1212 else if (v == &PL_vtbl_env) s = "env";
1213 else if (v == &PL_vtbl_envelem) s = "envelem";
1214 else if (v == &PL_vtbl_sig) s = "sig";
1215 else if (v == &PL_vtbl_sigelem) s = "sigelem";
1216 else if (v == &PL_vtbl_pack) s = "pack";
1217 else if (v == &PL_vtbl_packelem) s = "packelem";
1218 else if (v == &PL_vtbl_dbline) s = "dbline";
1219 else if (v == &PL_vtbl_isa) s = "isa";
1220 else if (v == &PL_vtbl_arylen) s = "arylen";
1221 else if (v == &PL_vtbl_mglob) s = "mglob";
1222 else if (v == &PL_vtbl_nkeys) s = "nkeys";
1223 else if (v == &PL_vtbl_taint) s = "taint";
1224 else if (v == &PL_vtbl_substr) s = "substr";
1225 else if (v == &PL_vtbl_vec) s = "vec";
1226 else if (v == &PL_vtbl_pos) s = "pos";
1227 else if (v == &PL_vtbl_bm) s = "bm";
1228 else if (v == &PL_vtbl_fm) s = "fm";
1229 else if (v == &PL_vtbl_uvar) s = "uvar";
1230 else if (v == &PL_vtbl_defelem) s = "defelem";
1231 #ifdef USE_LOCALE_COLLATE
1232 else if (v == &PL_vtbl_collxfrm) s = "collxfrm";
1234 else if (v == &PL_vtbl_amagic) s = "amagic";
1235 else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1236 else if (v == &PL_vtbl_backref) s = "backref";
1237 else if (v == &PL_vtbl_utf8) s = "utf8";
1238 else if (v == &PL_vtbl_arylen_p) s = "arylen_p";
1239 else if (v == &PL_vtbl_hintselem) s = "hintselem";
1242 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
1244 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1247 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
1250 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
1254 const char *name = NULL;
1255 for (n = 0; magic_names[n].name; n++) {
1256 if (mg->mg_type == magic_names[n].type) {
1257 name = magic_names[n].name;
1262 Perl_dump_indent(aTHX_ level, file,
1263 " MG_TYPE = PERL_MAGIC_%s\n", name);
1265 Perl_dump_indent(aTHX_ level, file,
1266 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1270 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
1271 if (mg->mg_type == PERL_MAGIC_envelem &&
1272 mg->mg_flags & MGf_TAINTEDDIR)
1273 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
1274 if (mg->mg_flags & MGf_REFCOUNTED)
1275 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
1276 if (mg->mg_flags & MGf_GSKIP)
1277 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
1278 if (mg->mg_type == PERL_MAGIC_regex_global &&
1279 mg->mg_flags & MGf_MINMATCH)
1280 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
1283 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
1284 PTR2UV(mg->mg_obj));
1285 if (mg->mg_type == PERL_MAGIC_qr) {
1286 const regexp * const re = (regexp *)mg->mg_obj;
1287 SV * const dsv = sv_newmortal();
1288 const char * const s = pv_pretty(dsv, re->wrapped, re->wraplen,
1290 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1291 ((re->extflags & RXf_UTF8) ? PERL_PV_ESCAPE_UNI : 0))
1293 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1294 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
1297 if (mg->mg_flags & MGf_REFCOUNTED)
1298 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1301 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
1303 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1304 if (mg->mg_len >= 0) {
1305 if (mg->mg_type != PERL_MAGIC_utf8) {
1306 SV * const sv = newSVpvs("");
1307 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1311 else if (mg->mg_len == HEf_SVKEY) {
1312 PerlIO_puts(file, " => HEf_SVKEY\n");
1313 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1317 PerlIO_puts(file, " ???? - please notify IZ");
1318 PerlIO_putc(file, '\n');
1320 if (mg->mg_type == PERL_MAGIC_utf8) {
1321 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1324 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1325 Perl_dump_indent(aTHX_ level, file,
1326 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1329 (UV)cache[i * 2 + 1]);
1336 Perl_magic_dump(pTHX_ const MAGIC *mg)
1338 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1342 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1345 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1346 if (sv && (hvname = HvNAME_get(sv)))
1347 PerlIO_printf(file, "\t\"%s\"\n", hvname);
1349 PerlIO_putc(file, '\n');
1353 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1355 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1356 if (sv && GvNAME(sv))
1357 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1359 PerlIO_putc(file, '\n');
1363 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1365 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1366 if (sv && GvNAME(sv)) {
1368 PerlIO_printf(file, "\t\"");
1369 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1370 PerlIO_printf(file, "%s\" :: \"", hvname);
1371 PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1374 PerlIO_putc(file, '\n');
1378 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1387 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1391 flags = SvFLAGS(sv);
1394 d = Perl_newSVpvf(aTHX_
1395 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
1396 PTR2UV(SvANY(sv)), PTR2UV(sv),
1397 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1398 (int)(PL_dumpindent*level), "");
1400 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1401 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,");
1403 if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1404 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1405 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1407 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
1408 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
1409 if (flags & SVs_GMG) sv_catpv(d, "GMG,");
1410 if (flags & SVs_SMG) sv_catpv(d, "SMG,");
1411 if (flags & SVs_RMG) sv_catpv(d, "RMG,");
1413 if (flags & SVf_IOK) sv_catpv(d, "IOK,");
1414 if (flags & SVf_NOK) sv_catpv(d, "NOK,");
1415 if (flags & SVf_POK) sv_catpv(d, "POK,");
1416 if (flags & SVf_ROK) {
1417 sv_catpv(d, "ROK,");
1418 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1420 if (flags & SVf_OOK) sv_catpv(d, "OOK,");
1421 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
1422 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
1423 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,");
1425 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
1426 if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
1427 if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
1428 if (flags & SVp_POK) sv_catpv(d, "pPOK,");
1429 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1430 if (SvPCS_IMPORTED(sv))
1431 sv_catpv(d, "PCS_IMPORTED,");
1433 sv_catpv(d, "SCREAM,");
1439 if (CvANON(sv)) sv_catpv(d, "ANON,");
1440 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1441 if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
1442 if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
1443 if (CvCONST(sv)) sv_catpv(d, "CONST,");
1444 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
1445 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
1446 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,");
1447 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,");
1448 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,");
1449 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
1452 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1453 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
1454 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
1455 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
1456 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1460 if (isGV_with_GP(sv)) {
1461 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1462 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
1463 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
1464 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1465 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1467 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1468 sv_catpv(d, "IMPORT");
1469 if (GvIMPORTED(sv) == GVf_IMPORTED)
1470 sv_catpv(d, "ALL,");
1473 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1474 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1475 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1476 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1480 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1481 if (SvVALID(sv)) sv_catpv(d, "VALID,");
1485 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
1486 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
1489 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
1490 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
1493 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1498 /* SVphv_SHAREKEYS is also 0x20000000 */
1499 if ((type != SVt_PVHV) && SvUTF8(sv))
1500 sv_catpv(d, "UTF8");
1502 if (*(SvEND(d) - 1) == ',') {
1503 SvCUR_set(d, SvCUR(d) - 1);
1504 SvPVX(d)[SvCUR(d)] = '\0';
1509 #ifdef DEBUG_LEAKING_SCALARS
1510 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1511 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1513 sv->sv_debug_inpad ? "for" : "by",
1514 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1515 sv->sv_debug_cloned ? " (cloned)" : "");
1517 Perl_dump_indent(aTHX_ level, file, "SV = ");
1518 if (type < SVt_LAST) {
1519 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1521 if (type == SVt_NULL) {
1526 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1530 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1531 && type != SVt_PVCV && !isGV_with_GP(sv))
1532 || (type == SVt_IV && !SvROK(sv))) {
1534 #ifdef PERL_OLD_COPY_ON_WRITE
1538 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
1540 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
1542 PerlIO_printf(file, " (OFFSET)");
1543 #ifdef PERL_OLD_COPY_ON_WRITE
1544 if (SvIsCOW_shared_hash(sv))
1545 PerlIO_printf(file, " (HASH)");
1546 else if (SvIsCOW_normal(sv))
1547 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1549 PerlIO_putc(file, '\n');
1551 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1552 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1553 (UV) COP_SEQ_RANGE_LOW(sv));
1554 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1555 (UV) COP_SEQ_RANGE_HIGH(sv));
1556 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1557 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)
1559 || type == SVt_NV) {
1560 STORE_NUMERIC_LOCAL_SET_STANDARD();
1561 /* %Vg doesn't work? --jhi */
1562 #ifdef USE_LONG_DOUBLE
1563 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1565 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
1567 RESTORE_NUMERIC_LOCAL();
1570 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1572 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1574 if (type < SVt_PV) {
1578 if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1579 if (SvPVX_const(sv)) {
1580 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1582 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1583 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1584 if (SvUTF8(sv)) /* the 6? \x{....} */
1585 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1586 PerlIO_printf(file, "\n");
1587 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1588 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
1591 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
1593 if (type == SVt_REGEXP) {
1594 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
1595 PTR2UV(((struct xregexp *)SvANY(sv))->xrx_regexp));
1597 if (type >= SVt_PVMG) {
1598 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1599 HV * const ost = SvOURSTASH(sv);
1601 do_hv_dump(level, file, " OURSTASH", ost);
1604 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1607 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1611 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1612 if (AvARRAY(sv) != AvALLOC(sv)) {
1613 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1614 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1617 PerlIO_putc(file, '\n');
1618 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1619 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
1620 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1621 sv_setpvn(d, "", 0);
1622 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1623 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
1624 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1625 SvCUR(d) ? SvPVX_const(d) + 1 : "");
1626 if (nest < maxnest && av_len((AV*)sv) >= 0) {
1628 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) {
1629 SV** const elt = av_fetch((AV*)sv,count,0);
1631 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1633 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1638 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1639 if (HvARRAY(sv) && HvKEYS(sv)) {
1640 /* Show distribution of HEs in the ARRAY */
1642 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1645 U32 pow2 = 2, keys = HvKEYS(sv);
1646 NV theoret, sum = 0;
1648 PerlIO_printf(file, " (");
1649 Zero(freq, FREQ_MAX + 1, int);
1650 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1653 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1655 if (count > FREQ_MAX)
1661 for (i = 0; i <= max; i++) {
1663 PerlIO_printf(file, "%d%s:%d", i,
1664 (i == FREQ_MAX) ? "+" : "",
1667 PerlIO_printf(file, ", ");
1670 PerlIO_putc(file, ')');
1671 /* The "quality" of a hash is defined as the total number of
1672 comparisons needed to access every element once, relative
1673 to the expected number needed for a random hash.
1675 The total number of comparisons is equal to the sum of
1676 the squares of the number of entries in each bucket.
1677 For a random hash of n keys into k buckets, the expected
1682 for (i = max; i > 0; i--) { /* Precision: count down. */
1683 sum += freq[i] * i * i;
1685 while ((keys = keys >> 1))
1687 theoret = HvKEYS(sv);
1688 theoret += theoret * (theoret-1)/pow2;
1689 PerlIO_putc(file, '\n');
1690 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
1692 PerlIO_putc(file, '\n');
1693 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1694 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1695 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
1696 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1697 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1699 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1700 if (mg && mg->mg_obj) {
1701 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1705 const char * const hvname = HvNAME_get(sv);
1707 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1710 const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1712 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1714 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1718 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1720 HV * const hv = (HV*)sv;
1721 int count = maxnest - nest;
1724 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1727 const U32 hash = HeHASH(he);
1728 SV * const keysv = hv_iterkeysv(he);
1729 const char * const keypv = SvPV_const(keysv, len);
1730 SV * const elt = hv_iterval(hv, he);
1732 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1734 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1736 PerlIO_printf(file, "[REHASH] ");
1737 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1738 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1740 hv_iterinit(hv); /* Return to status quo */
1746 const char *const proto = SvPV_const(sv, len);
1747 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1752 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
1753 if (!CvISXSUB(sv)) {
1755 Perl_dump_indent(aTHX_ level, file,
1756 " START = 0x%"UVxf" ===> %"IVdf"\n",
1757 PTR2UV(CvSTART(sv)),
1758 (IV)sequence_num(CvSTART(sv)));
1760 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1761 PTR2UV(CvROOT(sv)));
1762 if (CvROOT(sv) && dumpops) {
1763 do_op_dump(level+1, file, CvROOT(sv));
1766 SV * const constant = cv_const_sv((CV *)sv);
1768 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1771 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1773 PTR2UV(CvXSUBANY(sv).any_ptr));
1774 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1777 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1778 (IV)CvXSUBANY(sv).any_i32);
1781 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
1782 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
1783 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1784 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1785 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1786 if (type == SVt_PVFM)
1787 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1788 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1789 if (nest < maxnest) {
1790 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1793 const CV * const outside = CvOUTSIDE(sv);
1794 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
1797 : CvANON(outside) ? "ANON"
1798 : (outside == PL_main_cv) ? "MAIN"
1799 : CvUNIQUE(outside) ? "UNIQUE"
1800 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1802 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1803 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1807 if (type == SVt_PVLV) {
1808 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1809 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1810 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1811 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1812 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1813 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1817 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1818 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1819 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1820 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1822 if (!isGV_with_GP(sv))
1824 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
1825 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1826 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
1827 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1830 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1831 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1832 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1833 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1834 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1835 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1836 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1837 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1838 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
1839 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
1840 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1841 do_gv_dump (level, file, " EGV", GvEGV(sv));
1844 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1845 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1846 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1847 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1848 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1849 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1850 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1852 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1853 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1854 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1856 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1857 PTR2UV(IoTOP_GV(sv)));
1858 do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1861 /* Source filters hide things that are not GVs in these three, so let's
1862 be careful out there. */
1864 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1865 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1866 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1868 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1869 PTR2UV(IoFMT_GV(sv)));
1870 do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1873 if (IoBOTTOM_NAME(sv))
1874 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1875 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1876 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1878 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1879 PTR2UV(IoBOTTOM_GV(sv)));
1880 do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1883 if (isPRINT(IoTYPE(sv)))
1884 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
1886 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
1887 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1894 Perl_sv_dump(pTHX_ SV *sv)
1898 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1900 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1904 Perl_runops_debug(pTHX)
1908 if (ckWARN_d(WARN_DEBUGGING))
1909 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1913 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1917 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1918 PerlIO_printf(Perl_debug_log,
1919 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1920 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1921 PTR2UV(*PL_watchaddr));
1922 if (DEBUG_s_TEST_) {
1923 if (DEBUG_v_TEST_) {
1924 PerlIO_printf(Perl_debug_log, "\n");
1932 if (DEBUG_t_TEST_) debop(PL_op);
1933 if (DEBUG_P_TEST_) debprof(PL_op);
1935 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1936 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1943 Perl_debop(pTHX_ const OP *o)
1946 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1949 Perl_deb(aTHX_ "%s", OP_NAME(o));
1950 switch (o->op_type) {
1952 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1957 SV * const sv = newSV(0);
1959 /* FIXME - is this making unwarranted assumptions about the
1960 UTF-8 cleanliness of the dump file handle? */
1963 gv_fullname3(sv, cGVOPo_gv, NULL);
1964 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1968 PerlIO_printf(Perl_debug_log, "(NULL)");
1974 /* print the lexical's name */
1975 CV * const cv = deb_curcv(cxstack_ix);
1978 AV * const padlist = CvPADLIST(cv);
1979 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1980 sv = *av_fetch(comppad, o->op_targ, FALSE);
1984 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1986 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1992 PerlIO_printf(Perl_debug_log, "\n");
1997 S_deb_curcv(pTHX_ const I32 ix)
2000 const PERL_CONTEXT * const cx = &cxstack[ix];
2001 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2002 return cx->blk_sub.cv;
2003 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2005 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2010 return deb_curcv(ix - 1);
2014 Perl_watch(pTHX_ char **addr)
2017 PL_watchaddr = addr;
2019 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2020 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2024 S_debprof(pTHX_ const OP *o)
2027 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2029 if (!PL_profiledata)
2030 Newxz(PL_profiledata, MAXO, U32);
2031 ++PL_profiledata[o->op_type];
2035 Perl_debprofdump(pTHX)
2039 if (!PL_profiledata)
2041 for (i = 0; i < MAXO; i++) {
2042 if (PL_profiledata[i])
2043 PerlIO_printf(Perl_debug_log,
2044 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2051 * XML variants of most of the above routines
2055 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2058 PerlIO_printf(file, "\n ");
2059 va_start(args, pat);
2060 xmldump_vindent(level, file, pat, &args);
2066 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2069 va_start(args, pat);
2070 xmldump_vindent(level, file, pat, &args);
2075 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2077 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2078 PerlIO_vprintf(file, pat, *args);
2082 Perl_xmldump_all(pTHX)
2084 PerlIO_setlinebuf(PL_xmlfp);
2086 op_xmldump(PL_main_root);
2087 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2088 PerlIO_close(PL_xmlfp);
2093 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2098 if (!HvARRAY(stash))
2100 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2101 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2102 GV *gv = (GV*)HeVAL(entry);
2104 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2110 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2111 && (hv = GvHV(gv)) && hv != PL_defstash)
2112 xmldump_packsubs(hv); /* nested package */
2118 Perl_xmldump_sub(pTHX_ const GV *gv)
2120 SV * const sv = sv_newmortal();
2122 gv_fullname3(sv, gv, NULL);
2123 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2124 if (CvXSUB(GvCV(gv)))
2125 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2126 PTR2UV(CvXSUB(GvCV(gv))),
2127 (int)CvXSUBANY(GvCV(gv)).any_i32);
2128 else if (CvROOT(GvCV(gv)))
2129 op_xmldump(CvROOT(GvCV(gv)));
2131 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2135 Perl_xmldump_form(pTHX_ const GV *gv)
2137 SV * const sv = sv_newmortal();
2139 gv_fullname3(sv, gv, NULL);
2140 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2141 if (CvROOT(GvFORM(gv)))
2142 op_xmldump(CvROOT(GvFORM(gv)));
2144 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2148 Perl_xmldump_eval(pTHX)
2150 op_xmldump(PL_eval_root);
2154 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2156 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2160 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2163 const char * const e = pv + len;
2164 const char * const start = pv;
2168 sv_catpvn(dsv,"",0);
2169 dsvcur = SvCUR(dsv); /* in case we have to restart */
2174 c = utf8_to_uvchr((U8*)pv, &cl);
2176 SvCUR(dsv) = dsvcur;
2241 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2244 sv_catpvs(dsv, "<");
2247 sv_catpvs(dsv, ">");
2250 sv_catpvs(dsv, "&");
2253 sv_catpvs(dsv, """);
2257 if (c < 32 || c > 127) {
2258 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2261 const char string = (char) c;
2262 sv_catpvn(dsv, &string, 1);
2266 if ((c >= 0xD800 && c <= 0xDB7F) ||
2267 (c >= 0xDC00 && c <= 0xDFFF) ||
2268 (c >= 0xFFF0 && c <= 0xFFFF) ||
2270 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2272 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2285 Perl_sv_xmlpeek(pTHX_ SV *sv)
2287 SV * const t = sv_newmortal();
2292 sv_setpvn(t, "", 0);
2295 sv_catpv(t, "VOID=\"\"");
2298 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2299 sv_catpv(t, "WILD=\"\"");
2302 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2303 if (sv == &PL_sv_undef) {
2304 sv_catpv(t, "SV_UNDEF=\"1\"");
2305 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2306 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2310 else if (sv == &PL_sv_no) {
2311 sv_catpv(t, "SV_NO=\"1\"");
2312 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2313 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2314 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2315 SVp_POK|SVp_NOK)) &&
2320 else if (sv == &PL_sv_yes) {
2321 sv_catpv(t, "SV_YES=\"1\"");
2322 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2323 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2324 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2325 SVp_POK|SVp_NOK)) &&
2327 SvPVX(sv) && *SvPVX(sv) == '1' &&
2332 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2333 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2334 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2338 sv_catpv(t, " XXX=\"\" ");
2340 else if (SvREFCNT(sv) == 0) {
2341 sv_catpv(t, " refcnt=\"0\"");
2344 else if (DEBUG_R_TEST_) {
2347 /* is this SV on the tmps stack? */
2348 for (ix=PL_tmps_ix; ix>=0; ix--) {
2349 if (PL_tmps_stack[ix] == sv) {
2354 if (SvREFCNT(sv) > 1)
2355 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2358 sv_catpv(t, " DRT=\"<T>\"");
2362 sv_catpv(t, " ROK=\"\"");
2364 switch (SvTYPE(sv)) {
2366 sv_catpv(t, " FREED=\"1\"");
2370 sv_catpv(t, " UNDEF=\"1\"");
2373 sv_catpv(t, " IV=\"");
2376 sv_catpv(t, " NV=\"");
2379 sv_catpv(t, " PV=\"");
2382 sv_catpv(t, " PVIV=\"");
2385 sv_catpv(t, " PVNV=\"");
2388 sv_catpv(t, " PVMG=\"");
2391 sv_catpv(t, " PVLV=\"");
2394 sv_catpv(t, " AV=\"");
2397 sv_catpv(t, " HV=\"");
2401 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2403 sv_catpv(t, " CV=\"()\"");
2406 sv_catpv(t, " GV=\"");
2409 sv_catpv(t, " BIND=\"");
2412 sv_catpv(t, " ORANGE=\"");
2415 sv_catpv(t, " FM=\"");
2418 sv_catpv(t, " IO=\"");
2427 else if (SvNOKp(sv)) {
2428 STORE_NUMERIC_LOCAL_SET_STANDARD();
2429 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2430 RESTORE_NUMERIC_LOCAL();
2432 else if (SvIOKp(sv)) {
2434 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2436 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2445 return SvPV(t, n_a);
2449 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2452 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2455 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2458 const regexp *const r = PM_GETRE(pm);
2459 SV * const tmpsv = newSVpvn(r->precomp,r->prelen);
2461 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2463 SvREFCNT_dec(tmpsv);
2464 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2465 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2468 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2469 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2470 SV * const tmpsv = pm_description(pm);
2471 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2472 SvREFCNT_dec(tmpsv);
2476 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2477 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2478 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2479 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2480 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2481 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2484 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2488 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2490 do_pmop_xmldump(0, PL_xmlfp, pm);
2494 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2501 seq = sequence_num(o);
2502 Perl_xmldump_indent(aTHX_ level, file,
2503 "<op_%s seq=\"%"UVuf" -> ",
2508 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2509 sequence_num(o->op_next));
2511 PerlIO_printf(file, "DONE\"");
2514 if (o->op_type == OP_NULL)
2516 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2517 if (o->op_targ == OP_NEXTSTATE)
2520 PerlIO_printf(file, " line=\"%"UVuf"\"",
2521 (UV)CopLINE(cCOPo));
2522 if (CopSTASHPV(cCOPo))
2523 PerlIO_printf(file, " package=\"%s\"",
2525 if (cCOPo->cop_label)
2526 PerlIO_printf(file, " label=\"%s\"",
2531 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2534 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2537 SV * const tmpsv = newSVpvn("", 0);
2538 switch (o->op_flags & OPf_WANT) {
2540 sv_catpv(tmpsv, ",VOID");
2542 case OPf_WANT_SCALAR:
2543 sv_catpv(tmpsv, ",SCALAR");
2546 sv_catpv(tmpsv, ",LIST");
2549 sv_catpv(tmpsv, ",UNKNOWN");
2552 if (o->op_flags & OPf_KIDS)
2553 sv_catpv(tmpsv, ",KIDS");
2554 if (o->op_flags & OPf_PARENS)
2555 sv_catpv(tmpsv, ",PARENS");
2556 if (o->op_flags & OPf_STACKED)
2557 sv_catpv(tmpsv, ",STACKED");
2558 if (o->op_flags & OPf_REF)
2559 sv_catpv(tmpsv, ",REF");
2560 if (o->op_flags & OPf_MOD)
2561 sv_catpv(tmpsv, ",MOD");
2562 if (o->op_flags & OPf_SPECIAL)
2563 sv_catpv(tmpsv, ",SPECIAL");
2564 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2565 SvREFCNT_dec(tmpsv);
2567 if (o->op_private) {
2568 SV * const tmpsv = newSVpvn("", 0);
2569 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2570 if (o->op_private & OPpTARGET_MY)
2571 sv_catpv(tmpsv, ",TARGET_MY");
2573 else if (o->op_type == OP_LEAVESUB ||
2574 o->op_type == OP_LEAVE ||
2575 o->op_type == OP_LEAVESUBLV ||
2576 o->op_type == OP_LEAVEWRITE) {
2577 if (o->op_private & OPpREFCOUNTED)
2578 sv_catpv(tmpsv, ",REFCOUNTED");
2580 else if (o->op_type == OP_AASSIGN) {
2581 if (o->op_private & OPpASSIGN_COMMON)
2582 sv_catpv(tmpsv, ",COMMON");
2584 else if (o->op_type == OP_SASSIGN) {
2585 if (o->op_private & OPpASSIGN_BACKWARDS)
2586 sv_catpv(tmpsv, ",BACKWARDS");
2588 else if (o->op_type == OP_TRANS) {
2589 if (o->op_private & OPpTRANS_SQUASH)
2590 sv_catpv(tmpsv, ",SQUASH");
2591 if (o->op_private & OPpTRANS_DELETE)
2592 sv_catpv(tmpsv, ",DELETE");
2593 if (o->op_private & OPpTRANS_COMPLEMENT)
2594 sv_catpv(tmpsv, ",COMPLEMENT");
2595 if (o->op_private & OPpTRANS_IDENTICAL)
2596 sv_catpv(tmpsv, ",IDENTICAL");
2597 if (o->op_private & OPpTRANS_GROWS)
2598 sv_catpv(tmpsv, ",GROWS");
2600 else if (o->op_type == OP_REPEAT) {
2601 if (o->op_private & OPpREPEAT_DOLIST)
2602 sv_catpv(tmpsv, ",DOLIST");
2604 else if (o->op_type == OP_ENTERSUB ||
2605 o->op_type == OP_RV2SV ||
2606 o->op_type == OP_GVSV ||
2607 o->op_type == OP_RV2AV ||
2608 o->op_type == OP_RV2HV ||
2609 o->op_type == OP_RV2GV ||
2610 o->op_type == OP_AELEM ||
2611 o->op_type == OP_HELEM )
2613 if (o->op_type == OP_ENTERSUB) {
2614 if (o->op_private & OPpENTERSUB_AMPER)
2615 sv_catpv(tmpsv, ",AMPER");
2616 if (o->op_private & OPpENTERSUB_DB)
2617 sv_catpv(tmpsv, ",DB");
2618 if (o->op_private & OPpENTERSUB_HASTARG)
2619 sv_catpv(tmpsv, ",HASTARG");
2620 if (o->op_private & OPpENTERSUB_NOPAREN)
2621 sv_catpv(tmpsv, ",NOPAREN");
2622 if (o->op_private & OPpENTERSUB_INARGS)
2623 sv_catpv(tmpsv, ",INARGS");
2624 if (o->op_private & OPpENTERSUB_NOMOD)
2625 sv_catpv(tmpsv, ",NOMOD");
2628 switch (o->op_private & OPpDEREF) {
2630 sv_catpv(tmpsv, ",SV");
2633 sv_catpv(tmpsv, ",AV");
2636 sv_catpv(tmpsv, ",HV");
2639 if (o->op_private & OPpMAYBE_LVSUB)
2640 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2642 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2643 if (o->op_private & OPpLVAL_DEFER)
2644 sv_catpv(tmpsv, ",LVAL_DEFER");
2647 if (o->op_private & HINT_STRICT_REFS)
2648 sv_catpv(tmpsv, ",STRICT_REFS");
2649 if (o->op_private & OPpOUR_INTRO)
2650 sv_catpv(tmpsv, ",OUR_INTRO");
2653 else if (o->op_type == OP_CONST) {
2654 if (o->op_private & OPpCONST_BARE)
2655 sv_catpv(tmpsv, ",BARE");
2656 if (o->op_private & OPpCONST_STRICT)
2657 sv_catpv(tmpsv, ",STRICT");
2658 if (o->op_private & OPpCONST_ARYBASE)
2659 sv_catpv(tmpsv, ",ARYBASE");
2660 if (o->op_private & OPpCONST_WARNING)
2661 sv_catpv(tmpsv, ",WARNING");
2662 if (o->op_private & OPpCONST_ENTERED)
2663 sv_catpv(tmpsv, ",ENTERED");
2665 else if (o->op_type == OP_FLIP) {
2666 if (o->op_private & OPpFLIP_LINENUM)
2667 sv_catpv(tmpsv, ",LINENUM");
2669 else if (o->op_type == OP_FLOP) {
2670 if (o->op_private & OPpFLIP_LINENUM)
2671 sv_catpv(tmpsv, ",LINENUM");
2673 else if (o->op_type == OP_RV2CV) {
2674 if (o->op_private & OPpLVAL_INTRO)
2675 sv_catpv(tmpsv, ",INTRO");
2677 else if (o->op_type == OP_GV) {
2678 if (o->op_private & OPpEARLY_CV)
2679 sv_catpv(tmpsv, ",EARLY_CV");
2681 else if (o->op_type == OP_LIST) {
2682 if (o->op_private & OPpLIST_GUESSED)
2683 sv_catpv(tmpsv, ",GUESSED");
2685 else if (o->op_type == OP_DELETE) {
2686 if (o->op_private & OPpSLICE)
2687 sv_catpv(tmpsv, ",SLICE");
2689 else if (o->op_type == OP_EXISTS) {
2690 if (o->op_private & OPpEXISTS_SUB)
2691 sv_catpv(tmpsv, ",EXISTS_SUB");
2693 else if (o->op_type == OP_SORT) {
2694 if (o->op_private & OPpSORT_NUMERIC)
2695 sv_catpv(tmpsv, ",NUMERIC");
2696 if (o->op_private & OPpSORT_INTEGER)
2697 sv_catpv(tmpsv, ",INTEGER");
2698 if (o->op_private & OPpSORT_REVERSE)
2699 sv_catpv(tmpsv, ",REVERSE");
2701 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2702 if (o->op_private & OPpOPEN_IN_RAW)
2703 sv_catpv(tmpsv, ",IN_RAW");
2704 if (o->op_private & OPpOPEN_IN_CRLF)
2705 sv_catpv(tmpsv, ",IN_CRLF");
2706 if (o->op_private & OPpOPEN_OUT_RAW)
2707 sv_catpv(tmpsv, ",OUT_RAW");
2708 if (o->op_private & OPpOPEN_OUT_CRLF)
2709 sv_catpv(tmpsv, ",OUT_CRLF");
2711 else if (o->op_type == OP_EXIT) {
2712 if (o->op_private & OPpEXIT_VMSISH)
2713 sv_catpv(tmpsv, ",EXIT_VMSISH");
2714 if (o->op_private & OPpHUSH_VMSISH)
2715 sv_catpv(tmpsv, ",HUSH_VMSISH");
2717 else if (o->op_type == OP_DIE) {
2718 if (o->op_private & OPpHUSH_VMSISH)
2719 sv_catpv(tmpsv, ",HUSH_VMSISH");
2721 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2722 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2723 sv_catpv(tmpsv, ",FT_ACCESS");
2724 if (o->op_private & OPpFT_STACKED)
2725 sv_catpv(tmpsv, ",FT_STACKED");
2727 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2728 sv_catpv(tmpsv, ",INTRO");
2730 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2731 SvREFCNT_dec(tmpsv);
2734 switch (o->op_type) {
2736 if (o->op_flags & OPf_SPECIAL) {
2742 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2744 if (cSVOPo->op_sv) {
2745 SV * const tmpsv1 = newSV(0);
2746 SV * const tmpsv2 = newSVpvn("",0);
2754 gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
2755 s = SvPV(tmpsv1,len);
2756 sv_catxmlpvn(tmpsv2, s, len, 1);
2757 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2761 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2765 case OP_METHOD_NAMED:
2766 #ifndef USE_ITHREADS
2767 /* with ITHREADS, consts are stored in the pad, and the right pad
2768 * may not be active here, so skip */
2769 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2775 PerlIO_printf(file, ">\n");
2777 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2783 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2784 (UV)CopLINE(cCOPo));
2785 if (CopSTASHPV(cCOPo))
2786 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2788 if (cCOPo->cop_label)
2789 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2793 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2794 if (cLOOPo->op_redoop)
2795 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2797 PerlIO_printf(file, "DONE\"");
2798 S_xmldump_attr(aTHX_ level, file, "next=\"");
2799 if (cLOOPo->op_nextop)
2800 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2802 PerlIO_printf(file, "DONE\"");
2803 S_xmldump_attr(aTHX_ level, file, "last=\"");
2804 if (cLOOPo->op_lastop)
2805 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2807 PerlIO_printf(file, "DONE\"");
2815 S_xmldump_attr(aTHX_ level, file, "other=\"");
2816 if (cLOGOPo->op_other)
2817 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2819 PerlIO_printf(file, "DONE\"");
2827 if (o->op_private & OPpREFCOUNTED)
2828 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2834 if (PL_madskills && o->op_madprop) {
2835 char prevkey = '\0';
2836 SV * const tmpsv = newSVpvn("", 0);
2837 const MADPROP* mp = o->op_madprop;
2839 sv_utf8_upgrade(tmpsv);
2842 PerlIO_printf(file, ">\n");
2844 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2847 char tmp = mp->mad_key;
2848 sv_setpvn(tmpsv,"\"",1);
2850 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2851 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2852 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2855 sv_catpv(tmpsv, "\"");
2856 switch (mp->mad_type) {
2858 sv_catpv(tmpsv, "NULL");
2859 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2862 sv_catpv(tmpsv, " val=\"");
2863 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2864 sv_catpv(tmpsv, "\"");
2865 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2868 sv_catpv(tmpsv, " val=\"");
2869 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2870 sv_catpv(tmpsv, "\"");
2871 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2874 if ((OP*)mp->mad_val) {
2875 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2876 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2877 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2881 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2887 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2889 SvREFCNT_dec(tmpsv);
2892 switch (o->op_type) {
2899 PerlIO_printf(file, ">\n");
2901 do_pmop_xmldump(level, file, cPMOPo);
2907 if (o->op_flags & OPf_KIDS) {
2911 PerlIO_printf(file, ">\n");
2913 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2914 do_op_xmldump(level, file, kid);
2918 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2920 PerlIO_printf(file, " />\n");
2924 Perl_op_xmldump(pTHX_ const OP *o)
2926 do_op_xmldump(0, PL_xmlfp, o);
2932 * c-indentation-style: bsd
2934 * indent-tabs-mode: t
2937 * ex: set ts=8 sts=4 sw=4 noet: