This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Record folded constants in the op tree
[perl5.git] / dump.c
1 /*    dump.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
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.
8  *
9  */
10
11 /*
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.'
14  *
15  *     [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
16  */
17
18 /* This file contains utility routines to dump the contents of SV and OP
19  * structures, as used by command-line options like -Dt and -Dx, and
20  * by Devel::Peek.
21  *
22  * It also holds the debugging version of the  runops function.
23  */
24
25 #include "EXTERN.h"
26 #define PERL_IN_DUMP_C
27 #include "perl.h"
28 #include "regcomp.h"
29 #include "proto.h"
30
31
32 static const char* const svtypenames[SVt_LAST] = {
33     "NULL",
34     "BIND",
35     "IV",
36     "NV",
37     "PV",
38     "PVIV",
39     "PVNV",
40     "PVMG",
41     "REGEXP",
42     "PVGV",
43     "PVLV",
44     "PVAV",
45     "PVHV",
46     "PVCV",
47     "PVFM",
48     "PVIO"
49 };
50
51
52 static const char* const svshorttypenames[SVt_LAST] = {
53     "UNDEF",
54     "BIND",
55     "IV",
56     "NV",
57     "PV",
58     "PVIV",
59     "PVNV",
60     "PVMG",
61     "REGEXP",
62     "GV",
63     "PVLV",
64     "AV",
65     "HV",
66     "CV",
67     "FM",
68     "IO"
69 };
70
71 struct flag_to_name {
72     U32 flag;
73     const char *name;
74 };
75
76 static void
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78                const struct flag_to_name *const end)
79 {
80     do {
81         if (flags & start->flag)
82             sv_catpv(sv, start->name);
83     } while (++start < end);
84 }
85
86 #define append_flags(sv, f, flags) \
87     S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
88
89
90
91 void
92 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
93 {
94     va_list args;
95     PERL_ARGS_ASSERT_DUMP_INDENT;
96     va_start(args, pat);
97     dump_vindent(level, file, pat, &args);
98     va_end(args);
99 }
100
101 void
102 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
103 {
104     dVAR;
105     PERL_ARGS_ASSERT_DUMP_VINDENT;
106     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
107     PerlIO_vprintf(file, pat, *args);
108 }
109
110 void
111 Perl_dump_all(pTHX)
112 {
113     dump_all_perl(FALSE);
114 }
115
116 void
117 Perl_dump_all_perl(pTHX_ bool justperl)
118 {
119
120     dVAR;
121     PerlIO_setlinebuf(Perl_debug_log);
122     if (PL_main_root)
123         op_dump(PL_main_root);
124     dump_packsubs_perl(PL_defstash, justperl);
125 }
126
127 void
128 Perl_dump_packsubs(pTHX_ const HV *stash)
129 {
130     PERL_ARGS_ASSERT_DUMP_PACKSUBS;
131     dump_packsubs_perl(stash, FALSE);
132 }
133
134 void
135 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
136 {
137     dVAR;
138     I32 i;
139
140     PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
141
142     if (!HvARRAY(stash))
143         return;
144     for (i = 0; i <= (I32) HvMAX(stash); i++) {
145         const HE *entry;
146         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
147             const GV * const gv = (const GV *)HeVAL(entry);
148             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
149                 continue;
150             if (GvCVu(gv))
151                 dump_sub_perl(gv, justperl);
152             if (GvFORM(gv))
153                 dump_form(gv);
154             if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
155                 const HV * const hv = GvHV(gv);
156                 if (hv && (hv != PL_defstash))
157                     dump_packsubs_perl(hv, justperl); /* nested package */
158             }
159         }
160     }
161 }
162
163 void
164 Perl_dump_sub(pTHX_ const GV *gv)
165 {
166     PERL_ARGS_ASSERT_DUMP_SUB;
167     dump_sub_perl(gv, FALSE);
168 }
169
170 void
171 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
172 {
173     SV * sv;
174
175     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
176
177     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
178         return;
179
180     sv = sv_newmortal();
181     gv_fullname3(sv, gv, NULL);
182     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
183     if (CvISXSUB(GvCV(gv)))
184         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
185             PTR2UV(CvXSUB(GvCV(gv))),
186             (int)CvXSUBANY(GvCV(gv)).any_i32);
187     else if (CvROOT(GvCV(gv)))
188         op_dump(CvROOT(GvCV(gv)));
189     else
190         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
191 }
192
193 void
194 Perl_dump_form(pTHX_ const GV *gv)
195 {
196     SV * const sv = sv_newmortal();
197
198     PERL_ARGS_ASSERT_DUMP_FORM;
199
200     gv_fullname3(sv, gv, NULL);
201     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
202     if (CvROOT(GvFORM(gv)))
203         op_dump(CvROOT(GvFORM(gv)));
204     else
205         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
206 }
207
208 void
209 Perl_dump_eval(pTHX)
210 {
211     dVAR;
212     op_dump(PL_eval_root);
213 }
214
215
216 /*
217 =for apidoc pv_escape
218
219 Escapes at most the first "count" chars of pv and puts the results into
220 dsv such that the size of the escaped string will not exceed "max" chars
221 and will not contain any incomplete escape sequences.
222
223 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
224 will also be escaped.
225
226 Normally the SV will be cleared before the escaped string is prepared,
227 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
228
229 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
230 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
231 using C<is_utf8_string()> to determine if it is Unicode.
232
233 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
234 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
235 chars above 127 will be escaped using this style; otherwise, only chars above
236 255 will be so escaped; other non printable chars will use octal or
237 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
238 then all chars below 255 will be treated as printable and
239 will be output as literals.
240
241 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
242 string will be escaped, regardless of max. If the output is to be in hex,
243 then it will be returned as a plain hex
244 sequence. Thus the output will either be a single char,
245 an octal escape sequence, a special escape like C<\n> or a hex value.
246
247 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
248 not a '\\'. This is because regexes very often contain backslashed
249 sequences, whereas '%' is not a particularly common character in patterns.
250
251 Returns a pointer to the escaped text as held by dsv.
252
253 =cut
254 */
255 #define PV_ESCAPE_OCTBUFSIZE 32
256
257 char *
258 Perl_pv_escape( pTHX_ SV *dsv, char const * const str, 
259                 const STRLEN count, const STRLEN max, 
260                 STRLEN * const escaped, const U32 flags ) 
261 {
262     const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
263     const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
264     char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
265     STRLEN wrote = 0;    /* chars written so far */
266     STRLEN chsize = 0;   /* size of data to be written */
267     STRLEN readsize = 1; /* size of data just read */
268     bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
269     const char *pv  = str;
270     const char * const end = pv + count; /* end of string */
271     octbuf[0] = esc;
272
273     PERL_ARGS_ASSERT_PV_ESCAPE;
274
275     if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
276             /* This won't alter the UTF-8 flag */
277             sv_setpvs(dsv, "");
278     }
279     
280     if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
281         isuni = 1;
282     
283     for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
284         const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
285         const U8 c = (U8)u & 0xFF;
286         
287         if ( ( u > 255 )
288           || (flags & PERL_PV_ESCAPE_ALL)
289           || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
290         {
291             if (flags & PERL_PV_ESCAPE_FIRSTCHAR) 
292                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
293                                       "%"UVxf, u);
294             else
295                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
296                                       "%cx{%"UVxf"}", esc, u);
297         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
298             chsize = 1;            
299         } else {         
300             if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
301                 chsize = 2;
302                 switch (c) {
303                 
304                 case '\\' : /* fallthrough */
305                 case '%'  : if ( c == esc )  {
306                                 octbuf[1] = esc;  
307                             } else {
308                                 chsize = 1;
309                             }
310                             break;
311                 case '\v' : octbuf[1] = 'v';  break;
312                 case '\t' : octbuf[1] = 't';  break;
313                 case '\r' : octbuf[1] = 'r';  break;
314                 case '\n' : octbuf[1] = 'n';  break;
315                 case '\f' : octbuf[1] = 'f';  break;
316                 case '"'  : 
317                         if ( dq == '"' ) 
318                                 octbuf[1] = '"';
319                         else 
320                             chsize = 1;
321                         break;
322                 default:
323                         if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
324                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
325                                                   "%c%03o", esc, c);
326                         else
327                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
328                                                   "%c%o", esc, c);
329                 }
330             } else {
331                 chsize = 1;
332             }
333         }
334         if ( max && (wrote + chsize > max) ) {
335             break;
336         } else if (chsize > 1) {
337             sv_catpvn(dsv, octbuf, chsize);
338             wrote += chsize;
339         } else {
340             /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
341                128-255 can be appended raw to the dsv. If dsv happens to be
342                UTF-8 then we need catpvf to upgrade them for us.
343                Or add a new API call sv_catpvc(). Think about that name, and
344                how to keep it clear that it's unlike the s of catpvs, which is
345                really an array octets, not a string.  */
346             Perl_sv_catpvf( aTHX_ dsv, "%c", c);
347             wrote++;
348         }
349         if ( flags & PERL_PV_ESCAPE_FIRSTCHAR ) 
350             break;
351     }
352     if (escaped != NULL)
353         *escaped= pv - str;
354     return SvPVX(dsv);
355 }
356 /*
357 =for apidoc pv_pretty
358
359 Converts a string into something presentable, handling escaping via
360 pv_escape() and supporting quoting and ellipses.
361
362 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be 
363 double quoted with any double quotes in the string escaped. Otherwise
364 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
365 angle brackets. 
366
367 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
368 string were output then an ellipsis C<...> will be appended to the
369 string. Note that this happens AFTER it has been quoted.
370
371 If start_color is non-null then it will be inserted after the opening
372 quote (if there is one) but before the escaped text. If end_color
373 is non-null then it will be inserted after the escaped text but before
374 any quotes or ellipses.
375
376 Returns a pointer to the prettified text as held by dsv.
377
378 =cut           
379 */
380
381 char *
382 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, 
383   const STRLEN max, char const * const start_color, char const * const end_color, 
384   const U32 flags ) 
385 {
386     const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
387     STRLEN escaped;
388  
389     PERL_ARGS_ASSERT_PV_PRETTY;
390    
391     if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
392             /* This won't alter the UTF-8 flag */
393             sv_setpvs(dsv, "");
394     }
395
396     if ( dq == '"' )
397         sv_catpvs(dsv, "\"");
398     else if ( flags & PERL_PV_PRETTY_LTGT )
399         sv_catpvs(dsv, "<");
400         
401     if ( start_color != NULL ) 
402         sv_catpv(dsv, start_color);
403     
404     pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );    
405     
406     if ( end_color != NULL ) 
407         sv_catpv(dsv, end_color);
408
409     if ( dq == '"' ) 
410         sv_catpvs( dsv, "\"");
411     else if ( flags & PERL_PV_PRETTY_LTGT )
412         sv_catpvs(dsv, ">");         
413     
414     if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
415             sv_catpvs(dsv, "...");
416  
417     return SvPVX(dsv);
418 }
419
420 /*
421 =for apidoc pv_display
422
423 Similar to
424
425   pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
426
427 except that an additional "\0" will be appended to the string when
428 len > cur and pv[cur] is "\0".
429
430 Note that the final string may be up to 7 chars longer than pvlim.
431
432 =cut
433 */
434
435 char *
436 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
437 {
438     PERL_ARGS_ASSERT_PV_DISPLAY;
439
440     pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
441     if (len > cur && pv[cur] == '\0')
442             sv_catpvs( dsv, "\\0");
443     return SvPVX(dsv);
444 }
445
446 char *
447 Perl_sv_peek(pTHX_ SV *sv)
448 {
449     dVAR;
450     SV * const t = sv_newmortal();
451     int unref = 0;
452     U32 type;
453
454     sv_setpvs(t, "");
455   retry:
456     if (!sv) {
457         sv_catpv(t, "VOID");
458         goto finish;
459     }
460     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
461         sv_catpv(t, "WILD");
462         goto finish;
463     }
464     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
465         if (sv == &PL_sv_undef) {
466             sv_catpv(t, "SV_UNDEF");
467             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
468                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
469                 SvREADONLY(sv))
470                 goto finish;
471         }
472         else if (sv == &PL_sv_no) {
473             sv_catpv(t, "SV_NO");
474             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
475                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
476                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
477                                   SVp_POK|SVp_NOK)) &&
478                 SvCUR(sv) == 0 &&
479                 SvNVX(sv) == 0.0)
480                 goto finish;
481         }
482         else if (sv == &PL_sv_yes) {
483             sv_catpv(t, "SV_YES");
484             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
485                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
486                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
487                                   SVp_POK|SVp_NOK)) &&
488                 SvCUR(sv) == 1 &&
489                 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
490                 SvNVX(sv) == 1.0)
491                 goto finish;
492         }
493         else {
494             sv_catpv(t, "SV_PLACEHOLDER");
495             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
496                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
497                 SvREADONLY(sv))
498                 goto finish;
499         }
500         sv_catpv(t, ":");
501     }
502     else if (SvREFCNT(sv) == 0) {
503         sv_catpv(t, "(");
504         unref++;
505     }
506     else if (DEBUG_R_TEST_) {
507         int is_tmp = 0;
508         I32 ix;
509         /* is this SV on the tmps stack? */
510         for (ix=PL_tmps_ix; ix>=0; ix--) {
511             if (PL_tmps_stack[ix] == sv) {
512                 is_tmp = 1;
513                 break;
514             }
515         }
516         if (SvREFCNT(sv) > 1)
517             Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
518                     is_tmp ? "T" : "");
519         else if (is_tmp)
520             sv_catpv(t, "<T>");
521     }
522
523     if (SvROK(sv)) {
524         sv_catpv(t, "\\");
525         if (SvCUR(t) + unref > 10) {
526             SvCUR_set(t, unref + 3);
527             *SvEND(t) = '\0';
528             sv_catpv(t, "...");
529             goto finish;
530         }
531         sv = SvRV(sv);
532         goto retry;
533     }
534     type = SvTYPE(sv);
535     if (type == SVt_PVCV) {
536         Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
537         goto finish;
538     } else if (type < SVt_LAST) {
539         sv_catpv(t, svshorttypenames[type]);
540
541         if (type == SVt_NULL)
542             goto finish;
543     } else {
544         sv_catpv(t, "FREED");
545         goto finish;
546     }
547
548     if (SvPOKp(sv)) {
549         if (!SvPVX_const(sv))
550             sv_catpv(t, "(null)");
551         else {
552             SV * const tmp = newSVpvs("");
553             sv_catpv(t, "(");
554             if (SvOOK(sv)) {
555                 STRLEN delta;
556                 SvOOK_offset(sv, delta);
557                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
558             }
559             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
560             if (SvUTF8(sv))
561                 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
562                                sv_uni_display(tmp, sv, 6 * SvCUR(sv),
563                                               UNI_DISPLAY_QQ));
564             SvREFCNT_dec(tmp);
565         }
566     }
567     else if (SvNOKp(sv)) {
568         STORE_NUMERIC_LOCAL_SET_STANDARD();
569         Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
570         RESTORE_NUMERIC_LOCAL();
571     }
572     else if (SvIOKp(sv)) {
573         if (SvIsUV(sv))
574             Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
575         else
576             Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
577     }
578     else
579         sv_catpv(t, "()");
580
581   finish:
582     while (unref--)
583         sv_catpv(t, ")");
584     if (PL_tainting && SvTAINTED(sv))
585         sv_catpv(t, " [tainted]");
586     return SvPV_nolen(t);
587 }
588
589 void
590 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
591 {
592     char ch;
593
594     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
595
596     if (!pm) {
597         Perl_dump_indent(aTHX_ level, file, "{}\n");
598         return;
599     }
600     Perl_dump_indent(aTHX_ level, file, "{\n");
601     level++;
602     if (pm->op_pmflags & PMf_ONCE)
603         ch = '?';
604     else
605         ch = '/';
606     if (PM_GETRE(pm))
607         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
608              ch, RX_PRECOMP(PM_GETRE(pm)), ch,
609              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
610     else
611         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
612     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
613         Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
614         op_dump(pm->op_pmreplrootu.op_pmreplroot);
615     }
616     if (pm->op_code_list) {
617         if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
618             Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
619             do_op_dump(level, file, pm->op_code_list);
620         }
621         else
622             Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
623                                     PTR2UV(pm->op_code_list));
624     }
625     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
626         SV * const tmpsv = pm_description(pm);
627         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
628         SvREFCNT_dec(tmpsv);
629     }
630
631     Perl_dump_indent(aTHX_ level-1, file, "}\n");
632 }
633
634 const struct flag_to_name pmflags_flags_names[] = {
635     {PMf_CONST, ",CONST"},
636     {PMf_KEEP, ",KEEP"},
637     {PMf_GLOBAL, ",GLOBAL"},
638     {PMf_CONTINUE, ",CONTINUE"},
639     {PMf_RETAINT, ",RETAINT"},
640     {PMf_EVAL, ",EVAL"},
641     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
642     {PMf_HAS_CV, ",HAS_CV"},
643     {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
644     {PMf_IS_QR, ",IS_QR"}
645 };
646
647 static SV *
648 S_pm_description(pTHX_ const PMOP *pm)
649 {
650     SV * const desc = newSVpvs("");
651     const REGEXP * const regex = PM_GETRE(pm);
652     const U32 pmflags = pm->op_pmflags;
653
654     PERL_ARGS_ASSERT_PM_DESCRIPTION;
655
656     if (pmflags & PMf_ONCE)
657         sv_catpv(desc, ",ONCE");
658 #ifdef USE_ITHREADS
659     if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
660         sv_catpv(desc, ":USED");
661 #else
662     if (pmflags & PMf_USED)
663         sv_catpv(desc, ":USED");
664 #endif
665
666     if (regex) {
667         if (RX_EXTFLAGS(regex) & RXf_TAINTED)
668             sv_catpv(desc, ",TAINTED");
669         if (RX_CHECK_SUBSTR(regex)) {
670             if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
671                 sv_catpv(desc, ",SCANFIRST");
672             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
673                 sv_catpv(desc, ",ALL");
674         }
675         if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
676             sv_catpv(desc, ",SKIPWHITE");
677     }
678
679     append_flags(desc, pmflags, pmflags_flags_names);
680     return desc;
681 }
682
683 void
684 Perl_pmop_dump(pTHX_ PMOP *pm)
685 {
686     do_pmop_dump(0, Perl_debug_log, pm);
687 }
688
689 /* Return a unique integer to represent the address of op o.
690  * If it already exists in PL_op_sequence, just return it;
691  * otherwise add it.
692  *  *** Note that this isn't thread-safe */
693
694 STATIC UV
695 S_sequence_num(pTHX_ const OP *o)
696 {
697     dVAR;
698     SV     *op,
699           **seq;
700     const char *key;
701     STRLEN  len;
702     if (!o)
703         return 0;
704     op = newSVuv(PTR2UV(o));
705     sv_2mortal(op);
706     key = SvPV_const(op, len);
707     if (!PL_op_sequence)
708         PL_op_sequence = newHV();
709     seq = hv_fetch(PL_op_sequence, key, len, 0);
710     if (seq)
711         return SvUV(*seq);
712     (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
713     return PL_op_seq;
714 }
715
716 const struct flag_to_name op_flags_names[] = {
717     {OPf_KIDS, ",KIDS"},
718     {OPf_PARENS, ",PARENS"},
719     {OPf_REF, ",REF"},
720     {OPf_MOD, ",MOD"},
721     {OPf_STACKED, ",STACKED"},
722     {OPf_SPECIAL, ",SPECIAL"}
723 };
724
725 const struct flag_to_name op_trans_names[] = {
726     {OPpTRANS_FROM_UTF, ",FROM_UTF"},
727     {OPpTRANS_TO_UTF, ",TO_UTF"},
728     {OPpTRANS_IDENTICAL, ",IDENTICAL"},
729     {OPpTRANS_SQUASH, ",SQUASH"},
730     {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
731     {OPpTRANS_GROWS, ",GROWS"},
732     {OPpTRANS_DELETE, ",DELETE"}
733 };
734
735 const struct flag_to_name op_entersub_names[] = {
736     {OPpENTERSUB_DB, ",DB"},
737     {OPpENTERSUB_HASTARG, ",HASTARG"},
738     {OPpENTERSUB_AMPER, ",AMPER"},
739     {OPpENTERSUB_NOPAREN, ",NOPAREN"},
740     {OPpENTERSUB_INARGS, ",INARGS"}
741 };
742
743 const struct flag_to_name op_const_names[] = {
744     {OPpCONST_NOVER, ",NOVER"},
745     {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
746     {OPpCONST_STRICT, ",STRICT"},
747     {OPpCONST_ENTERED, ",ENTERED"},
748     {OPpCONST_FOLDED, ",FOLDED"},
749     {OPpCONST_BARE, ",BARE"}
750 };
751
752 const struct flag_to_name op_sort_names[] = {
753     {OPpSORT_NUMERIC, ",NUMERIC"},
754     {OPpSORT_INTEGER, ",INTEGER"},
755     {OPpSORT_REVERSE, ",REVERSE"},
756     {OPpSORT_INPLACE, ",INPLACE"},
757     {OPpSORT_DESCEND, ",DESCEND"},
758     {OPpSORT_QSORT, ",QSORT"},
759     {OPpSORT_STABLE, ",STABLE"}
760 };
761
762 const struct flag_to_name op_open_names[] = {
763     {OPpOPEN_IN_RAW, ",IN_RAW"},
764     {OPpOPEN_IN_CRLF, ",IN_CRLF"},
765     {OPpOPEN_OUT_RAW, ",OUT_RAW"},
766     {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
767 };
768
769 const struct flag_to_name op_exit_names[] = {
770     {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
771     {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
772 };
773
774 #define OP_PRIVATE_ONCE(op, flag, name) \
775     const struct flag_to_name CAT2(op, _names)[] = {    \
776         {(flag), (name)} \
777     }
778
779 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
780 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
781 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
782 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
783 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
784 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
785 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
786 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
787 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
788 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
789 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
790 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
791
792 struct op_private_by_op {
793     U16 op_type;
794     U16 len;
795     const struct flag_to_name *start;
796 };
797
798 const struct op_private_by_op op_private_names[] = {
799     {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
800     {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
801     {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
802     {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803     {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
804     {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
805     {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
806     {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
807     {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
808     {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
809     {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
810     {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
811     {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
812     {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
813     {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
814     {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
815     {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
816     {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
817     {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
818     {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
819     {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
820 };
821
822 static bool
823 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
824     const struct op_private_by_op *start = op_private_names;
825     const struct op_private_by_op *const end
826         = op_private_names + C_ARRAY_LENGTH(op_private_names);
827
828     /* This is a linear search, but no worse than the code that it replaced.
829        It's debugging code - size is more important than speed.  */
830     do {
831         if (optype == start->op_type) {
832             S_append_flags(aTHX_ tmpsv, op_private, start->start,
833                            start->start + start->len);
834             return TRUE;
835         }
836     } while (++start < end);
837     return FALSE;
838 }
839
840 void
841 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
842 {
843     dVAR;
844     UV      seq;
845     const OPCODE optype = o->op_type;
846
847     PERL_ARGS_ASSERT_DO_OP_DUMP;
848
849     Perl_dump_indent(aTHX_ level, file, "{\n");
850     level++;
851     seq = sequence_num(o);
852     if (seq)
853         PerlIO_printf(file, "%-4"UVuf, seq);
854     else
855         PerlIO_printf(file, "????");
856     PerlIO_printf(file,
857                   "%*sTYPE = %s  ===> ",
858                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
859     if (o->op_next)
860         PerlIO_printf(file,
861                         o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
862                                 sequence_num(o->op_next));
863     else
864         PerlIO_printf(file, "NULL\n");
865     if (o->op_targ) {
866         if (optype == OP_NULL) {
867             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
868             if (o->op_targ == OP_NEXTSTATE) {
869                 if (CopLINE(cCOPo))
870                     Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
871                                      (UV)CopLINE(cCOPo));
872                 if (CopSTASHPV(cCOPo))
873                     Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
874                                      CopSTASHPV(cCOPo));
875                 if (CopLABEL(cCOPo))
876                     Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
877                                      CopLABEL(cCOPo));
878             }
879         }
880         else
881             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
882     }
883 #ifdef DUMPADDR
884     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
885 #endif
886     if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
887         SV * const tmpsv = newSVpvs("");
888         switch (o->op_flags & OPf_WANT) {
889         case OPf_WANT_VOID:
890             sv_catpv(tmpsv, ",VOID");
891             break;
892         case OPf_WANT_SCALAR:
893             sv_catpv(tmpsv, ",SCALAR");
894             break;
895         case OPf_WANT_LIST:
896             sv_catpv(tmpsv, ",LIST");
897             break;
898         default:
899             sv_catpv(tmpsv, ",UNKNOWN");
900             break;
901         }
902         append_flags(tmpsv, o->op_flags, op_flags_names);
903         if (o->op_latefree)
904             sv_catpv(tmpsv, ",LATEFREE");
905         if (o->op_latefreed)
906             sv_catpv(tmpsv, ",LATEFREED");
907         if (o->op_attached)
908             sv_catpv(tmpsv, ",ATTACHED");
909         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
910         SvREFCNT_dec(tmpsv);
911     }
912     if (o->op_private) {
913         SV * const tmpsv = newSVpvs("");
914         if (PL_opargs[optype] & OA_TARGLEX) {
915             if (o->op_private & OPpTARGET_MY)
916                 sv_catpv(tmpsv, ",TARGET_MY");
917         }
918         else if (optype == OP_ENTERSUB ||
919             optype == OP_RV2SV ||
920             optype == OP_GVSV ||
921             optype == OP_RV2AV ||
922             optype == OP_RV2HV ||
923             optype == OP_RV2GV ||
924             optype == OP_AELEM ||
925             optype == OP_HELEM )
926         {
927             if (optype == OP_ENTERSUB) {
928                 append_flags(tmpsv, o->op_private, op_entersub_names);
929             }
930             else {
931                 switch (o->op_private & OPpDEREF) {
932                 case OPpDEREF_SV:
933                     sv_catpv(tmpsv, ",SV");
934                     break;
935                 case OPpDEREF_AV:
936                     sv_catpv(tmpsv, ",AV");
937                     break;
938                 case OPpDEREF_HV:
939                     sv_catpv(tmpsv, ",HV");
940                     break;
941                 }
942                 if (o->op_private & OPpMAYBE_LVSUB)
943                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
944             }
945
946             if (optype == OP_AELEM || optype == OP_HELEM) {
947                 if (o->op_private & OPpLVAL_DEFER)
948                     sv_catpv(tmpsv, ",LVAL_DEFER");
949             }
950             else {
951                 if (o->op_private & HINT_STRICT_REFS)
952                     sv_catpv(tmpsv, ",STRICT_REFS");
953                 if (o->op_private & OPpOUR_INTRO)
954                     sv_catpv(tmpsv, ",OUR_INTRO");
955             }
956         }
957         else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
958         }
959         else if (PL_check[optype] != Perl_ck_ftst) {
960             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
961                 sv_catpv(tmpsv, ",FT_ACCESS");
962             if (o->op_private & OPpFT_STACKED)
963                 sv_catpv(tmpsv, ",FT_STACKED");
964         }
965         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
966             sv_catpv(tmpsv, ",INTRO");
967         if (SvCUR(tmpsv))
968             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
969         SvREFCNT_dec(tmpsv);
970     }
971
972 #ifdef PERL_MAD
973     if (PL_madskills && o->op_madprop) {
974         SV * const tmpsv = newSVpvs("");
975         MADPROP* mp = o->op_madprop;
976         Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
977         level++;
978         while (mp) {
979             const char tmp = mp->mad_key;
980             sv_setpvs(tmpsv,"'");
981             if (tmp)
982                 sv_catpvn(tmpsv, &tmp, 1);
983             sv_catpv(tmpsv, "'=");
984             switch (mp->mad_type) {
985             case MAD_NULL:
986                 sv_catpv(tmpsv, "NULL");
987                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
988                 break;
989             case MAD_PV:
990                 sv_catpv(tmpsv, "<");
991                 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
992                 sv_catpv(tmpsv, ">");
993                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
994                 break;
995             case MAD_OP:
996                 if ((OP*)mp->mad_val) {
997                     Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
998                     do_op_dump(level, file, (OP*)mp->mad_val);
999                 }
1000                 break;
1001             default:
1002                 sv_catpv(tmpsv, "(UNK)");
1003                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1004                 break;
1005             }
1006             mp = mp->mad_next;
1007         }
1008         level--;
1009         Perl_dump_indent(aTHX_ level, file, "}\n");
1010
1011         SvREFCNT_dec(tmpsv);
1012     }
1013 #endif
1014
1015     switch (optype) {
1016     case OP_AELEMFAST:
1017     case OP_GVSV:
1018     case OP_GV:
1019 #ifdef USE_ITHREADS
1020         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1021 #else
1022         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1023             if (cSVOPo->op_sv) {
1024                 SV * const tmpsv = newSV(0);
1025                 ENTER;
1026                 SAVEFREESV(tmpsv);
1027 #ifdef PERL_MAD
1028                 /* FIXME - is this making unwarranted assumptions about the
1029                    UTF-8 cleanliness of the dump file handle?  */
1030                 SvUTF8_on(tmpsv);
1031 #endif
1032                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1033                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1034                                  SvPV_nolen_const(tmpsv));
1035                 LEAVE;
1036             }
1037             else
1038                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1039         }
1040 #endif
1041         break;
1042     case OP_CONST:
1043     case OP_HINTSEVAL:
1044     case OP_METHOD_NAMED:
1045 #ifndef USE_ITHREADS
1046         /* with ITHREADS, consts are stored in the pad, and the right pad
1047          * may not be active here, so skip */
1048         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1049 #endif
1050         break;
1051     case OP_NEXTSTATE:
1052     case OP_DBSTATE:
1053         if (CopLINE(cCOPo))
1054             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1055                              (UV)CopLINE(cCOPo));
1056         if (CopSTASHPV(cCOPo))
1057             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1058                              CopSTASHPV(cCOPo));
1059         if (CopLABEL(cCOPo))
1060             Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1061                              CopLABEL(cCOPo));
1062         break;
1063     case OP_ENTERLOOP:
1064         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1065         if (cLOOPo->op_redoop)
1066             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1067         else
1068             PerlIO_printf(file, "DONE\n");
1069         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1070         if (cLOOPo->op_nextop)
1071             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1072         else
1073             PerlIO_printf(file, "DONE\n");
1074         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1075         if (cLOOPo->op_lastop)
1076             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1077         else
1078             PerlIO_printf(file, "DONE\n");
1079         break;
1080     case OP_COND_EXPR:
1081     case OP_RANGE:
1082     case OP_MAPWHILE:
1083     case OP_GREPWHILE:
1084     case OP_OR:
1085     case OP_AND:
1086         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1087         if (cLOGOPo->op_other)
1088             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1089         else
1090             PerlIO_printf(file, "DONE\n");
1091         break;
1092     case OP_PUSHRE:
1093     case OP_MATCH:
1094     case OP_QR:
1095     case OP_SUBST:
1096         do_pmop_dump(level, file, cPMOPo);
1097         break;
1098     case OP_LEAVE:
1099     case OP_LEAVEEVAL:
1100     case OP_LEAVESUB:
1101     case OP_LEAVESUBLV:
1102     case OP_LEAVEWRITE:
1103     case OP_SCOPE:
1104         if (o->op_private & OPpREFCOUNTED)
1105             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1106         break;
1107     default:
1108         break;
1109     }
1110     if (o->op_flags & OPf_KIDS) {
1111         OP *kid;
1112         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1113             do_op_dump(level, file, kid);
1114     }
1115     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1116 }
1117
1118 void
1119 Perl_op_dump(pTHX_ const OP *o)
1120 {
1121     PERL_ARGS_ASSERT_OP_DUMP;
1122     do_op_dump(0, Perl_debug_log, o);
1123 }
1124
1125 void
1126 Perl_gv_dump(pTHX_ GV *gv)
1127 {
1128     SV *sv;
1129
1130     PERL_ARGS_ASSERT_GV_DUMP;
1131
1132     if (!gv) {
1133         PerlIO_printf(Perl_debug_log, "{}\n");
1134         return;
1135     }
1136     sv = sv_newmortal();
1137     PerlIO_printf(Perl_debug_log, "{\n");
1138     gv_fullname3(sv, gv, NULL);
1139     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1140     if (gv != GvEGV(gv)) {
1141         gv_efullname3(sv, GvEGV(gv), NULL);
1142         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1143     }
1144     PerlIO_putc(Perl_debug_log, '\n');
1145     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1146 }
1147
1148
1149 /* map magic types to the symbolic names
1150  * (with the PERL_MAGIC_ prefixed stripped)
1151  */
1152
1153 static const struct { const char type; const char *name; } magic_names[] = {
1154 #include "mg_names.c"
1155         /* this null string terminates the list */
1156         { 0,                         NULL },
1157 };
1158
1159 void
1160 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1161 {
1162     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1163
1164     for (; mg; mg = mg->mg_moremagic) {
1165         Perl_dump_indent(aTHX_ level, file,
1166                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1167         if (mg->mg_virtual) {
1168             const MGVTBL * const v = mg->mg_virtual;
1169             if (v >= PL_magic_vtables
1170                 && v < PL_magic_vtables + magic_vtable_max) {
1171                 const U32 i = v - PL_magic_vtables;
1172                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1173             }
1174             else
1175                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1176         }
1177         else
1178             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1179
1180         if (mg->mg_private)
1181             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1182
1183         {
1184             int n;
1185             const char *name = NULL;
1186             for (n = 0; magic_names[n].name; n++) {
1187                 if (mg->mg_type == magic_names[n].type) {
1188                     name = magic_names[n].name;
1189                     break;
1190                 }
1191             }
1192             if (name)
1193                 Perl_dump_indent(aTHX_ level, file,
1194                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1195             else
1196                 Perl_dump_indent(aTHX_ level, file,
1197                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1198         }
1199
1200         if (mg->mg_flags) {
1201             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1202             if (mg->mg_type == PERL_MAGIC_envelem &&
1203                 mg->mg_flags & MGf_TAINTEDDIR)
1204                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1205             if (mg->mg_type == PERL_MAGIC_regex_global &&
1206                 mg->mg_flags & MGf_MINMATCH)
1207                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1208             if (mg->mg_flags & MGf_REFCOUNTED)
1209                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1210             if (mg->mg_flags & MGf_GSKIP)
1211                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1212             if (mg->mg_flags & MGf_COPY)
1213                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1214             if (mg->mg_flags & MGf_DUP)
1215                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1216             if (mg->mg_flags & MGf_LOCAL)
1217                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1218         }
1219         if (mg->mg_obj) {
1220             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1221                 PTR2UV(mg->mg_obj));
1222             if (mg->mg_type == PERL_MAGIC_qr) {
1223                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1224                 SV * const dsv = sv_newmortal();
1225                 const char * const s
1226                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1227                     60, NULL, NULL,
1228                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1229                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1230                 );
1231                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1232                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1233                         (IV)RX_REFCNT(re));
1234             }
1235             if (mg->mg_flags & MGf_REFCOUNTED)
1236                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1237         }
1238         if (mg->mg_len)
1239             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1240         if (mg->mg_ptr) {
1241             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1242             if (mg->mg_len >= 0) {
1243                 if (mg->mg_type != PERL_MAGIC_utf8) {
1244                     SV * const sv = newSVpvs("");
1245                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1246                     SvREFCNT_dec(sv);
1247                 }
1248             }
1249             else if (mg->mg_len == HEf_SVKEY) {
1250                 PerlIO_puts(file, " => HEf_SVKEY\n");
1251                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1252                            maxnest, dumpops, pvlim); /* MG is already +1 */
1253                 continue;
1254             }
1255             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1256             else
1257                 PerlIO_puts(
1258                   file,
1259                  " ???? - " __FILE__
1260                  " does not know how to handle this MG_LEN"
1261                 );
1262             PerlIO_putc(file, '\n');
1263         }
1264         if (mg->mg_type == PERL_MAGIC_utf8) {
1265             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1266             if (cache) {
1267                 IV i;
1268                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1269                     Perl_dump_indent(aTHX_ level, file,
1270                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1271                                      i,
1272                                      (UV)cache[i * 2],
1273                                      (UV)cache[i * 2 + 1]);
1274             }
1275         }
1276     }
1277 }
1278
1279 void
1280 Perl_magic_dump(pTHX_ const MAGIC *mg)
1281 {
1282     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1283 }
1284
1285 void
1286 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1287 {
1288     const char *hvname;
1289
1290     PERL_ARGS_ASSERT_DO_HV_DUMP;
1291
1292     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1293     if (sv && (hvname = HvNAME_get(sv)))
1294     {
1295         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1296            name which quite legally could contain insane things like tabs, newlines, nulls or
1297            other scary crap - this should produce sane results - except maybe for unicode package
1298            names - but we will wait for someone to file a bug on that - demerphq */
1299         SV * const tmpsv = newSVpvs("");
1300         PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1301     }
1302     else
1303         PerlIO_putc(file, '\n');
1304 }
1305
1306 void
1307 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1308 {
1309     PERL_ARGS_ASSERT_DO_GV_DUMP;
1310
1311     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1312     if (sv && GvNAME(sv))
1313         PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1314     else
1315         PerlIO_putc(file, '\n');
1316 }
1317
1318 void
1319 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1320 {
1321     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1322
1323     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1324     if (sv && GvNAME(sv)) {
1325         const char *hvname;
1326         PerlIO_printf(file, "\t\"");
1327         if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1328             PerlIO_printf(file, "%s\" :: \"", hvname);
1329         PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1330     }
1331     else
1332         PerlIO_putc(file, '\n');
1333 }
1334
1335 const struct flag_to_name first_sv_flags_names[] = {
1336     {SVs_TEMP, "TEMP,"},
1337     {SVs_OBJECT, "OBJECT,"},
1338     {SVs_GMG, "GMG,"},
1339     {SVs_SMG, "SMG,"},
1340     {SVs_RMG, "RMG,"},
1341     {SVf_IOK, "IOK,"},
1342     {SVf_NOK, "NOK,"},
1343     {SVf_POK, "POK,"}
1344 };
1345
1346 const struct flag_to_name second_sv_flags_names[] = {
1347     {SVf_OOK, "OOK,"},
1348     {SVf_FAKE, "FAKE,"},
1349     {SVf_READONLY, "READONLY,"},
1350     {SVf_BREAK, "BREAK,"},
1351     {SVf_AMAGIC, "OVERLOAD,"},
1352     {SVp_IOK, "pIOK,"},
1353     {SVp_NOK, "pNOK,"},
1354     {SVp_POK, "pPOK,"}
1355 };
1356
1357 const struct flag_to_name cv_flags_names[] = {
1358     {CVf_ANON, "ANON,"},
1359     {CVf_UNIQUE, "UNIQUE,"},
1360     {CVf_CLONE, "CLONE,"},
1361     {CVf_CLONED, "CLONED,"},
1362     {CVf_CONST, "CONST,"},
1363     {CVf_NODEBUG, "NODEBUG,"},
1364     {CVf_LVALUE, "LVALUE,"},
1365     {CVf_METHOD, "METHOD,"},
1366     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1367     {CVf_CVGV_RC, "CVGV_RC,"},
1368     {CVf_DYNFILE, "DYNFILE,"},
1369     {CVf_AUTOLOAD, "AUTOLOAD,"},
1370     {CVf_HASEVAL, "HASEVAL"},
1371     {CVf_SLABBED, "SLABBED,"},
1372     {CVf_ISXSUB, "ISXSUB,"}
1373 };
1374
1375 const struct flag_to_name hv_flags_names[] = {
1376     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1377     {SVphv_LAZYDEL, "LAZYDEL,"},
1378     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1379     {SVphv_REHASH, "REHASH,"},
1380     {SVphv_CLONEABLE, "CLONEABLE,"}
1381 };
1382
1383 const struct flag_to_name gp_flags_names[] = {
1384     {GVf_INTRO, "INTRO,"},
1385     {GVf_MULTI, "MULTI,"},
1386     {GVf_ASSUMECV, "ASSUMECV,"},
1387     {GVf_IN_PAD, "IN_PAD,"}
1388 };
1389
1390 const struct flag_to_name gp_flags_imported_names[] = {
1391     {GVf_IMPORTED_SV, " SV"},
1392     {GVf_IMPORTED_AV, " AV"},
1393     {GVf_IMPORTED_HV, " HV"},
1394     {GVf_IMPORTED_CV, " CV"},
1395 };
1396
1397 const struct flag_to_name regexp_flags_names[] = {
1398     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1399     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1400     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1401     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1402     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1403     {RXf_ANCH_BOL,        "ANCH_BOL,"},
1404     {RXf_ANCH_MBOL,       "ANCH_MBOL,"},
1405     {RXf_ANCH_SBOL,       "ANCH_SBOL,"},
1406     {RXf_ANCH_GPOS,       "ANCH_GPOS,"},
1407     {RXf_GPOS_SEEN,       "GPOS_SEEN,"},
1408     {RXf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1409     {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1410     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1411     {RXf_CANY_SEEN,       "CANY_SEEN,"},
1412     {RXf_NOSCAN,          "NOSCAN,"},
1413     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1414     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1415     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1416     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1417     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1418     {RXf_SPLIT,           "SPLIT,"},
1419     {RXf_COPY_DONE,       "COPY_DONE,"},
1420     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1421     {RXf_TAINTED,         "TAINTED,"},
1422     {RXf_START_ONLY,      "START_ONLY,"},
1423     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1424     {RXf_WHITE,           "WHITE,"},
1425     {RXf_NULL,            "NULL,"},
1426 };
1427
1428 void
1429 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1430 {
1431     dVAR;
1432     SV *d;
1433     const char *s;
1434     U32 flags;
1435     U32 type;
1436
1437     PERL_ARGS_ASSERT_DO_SV_DUMP;
1438
1439     if (!sv) {
1440         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1441         return;
1442     }
1443
1444     flags = SvFLAGS(sv);
1445     type = SvTYPE(sv);
1446
1447     /* process general SV flags */
1448
1449     d = Perl_newSVpvf(aTHX_
1450                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1451                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1452                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1453                    (int)(PL_dumpindent*level), "");
1454
1455     if (!((flags & SVpad_NAME) == SVpad_NAME
1456           && (type == SVt_PVMG || type == SVt_PVNV))) {
1457         if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1458             sv_catpv(d, "PADSTALE,");
1459     }
1460     if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1461         if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1462             sv_catpv(d, "PADTMP,");
1463         if (flags & SVs_PADMY)  sv_catpv(d, "PADMY,");
1464     }
1465     append_flags(d, flags, first_sv_flags_names);
1466     if (flags & SVf_ROK)  {     
1467                                 sv_catpv(d, "ROK,");
1468         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1469     }
1470     append_flags(d, flags, second_sv_flags_names);
1471     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1472         if (SvPCS_IMPORTED(sv))
1473                                 sv_catpv(d, "PCS_IMPORTED,");
1474         else
1475                                 sv_catpv(d, "SCREAM,");
1476     }
1477
1478     /* process type-specific SV flags */
1479
1480     switch (type) {
1481     case SVt_PVCV:
1482     case SVt_PVFM:
1483         append_flags(d, CvFLAGS(sv), cv_flags_names);
1484         break;
1485     case SVt_PVHV:
1486         append_flags(d, flags, hv_flags_names);
1487         break;
1488     case SVt_PVGV:
1489     case SVt_PVLV:
1490         if (isGV_with_GP(sv)) {
1491             append_flags(d, GvFLAGS(sv), gp_flags_names);
1492         }
1493         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1494             sv_catpv(d, "IMPORT");
1495             if (GvIMPORTED(sv) == GVf_IMPORTED)
1496                 sv_catpv(d, "ALL,");
1497             else {
1498                 sv_catpv(d, "(");
1499                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1500                 sv_catpv(d, " ),");
1501             }
1502         }
1503         /* FALL THROUGH */
1504     default:
1505     evaled_or_uv:
1506         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1507         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1508         break;
1509     case SVt_PVMG:
1510         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1511         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1512         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1513         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1514         /* FALL THROUGH */
1515     case SVt_PVNV:
1516         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1517         goto evaled_or_uv;
1518     case SVt_PVAV:
1519         break;
1520     }
1521     /* SVphv_SHAREKEYS is also 0x20000000 */
1522     if ((type != SVt_PVHV) && SvUTF8(sv))
1523         sv_catpv(d, "UTF8");
1524
1525     if (*(SvEND(d) - 1) == ',') {
1526         SvCUR_set(d, SvCUR(d) - 1);
1527         SvPVX(d)[SvCUR(d)] = '\0';
1528     }
1529     sv_catpv(d, ")");
1530     s = SvPVX_const(d);
1531
1532     /* dump initial SV details */
1533
1534 #ifdef DEBUG_LEAKING_SCALARS
1535     Perl_dump_indent(aTHX_ level, file,
1536         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1537         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1538         sv->sv_debug_line,
1539         sv->sv_debug_inpad ? "for" : "by",
1540         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1541         PTR2UV(sv->sv_debug_parent),
1542         sv->sv_debug_serial
1543     );
1544 #endif
1545     Perl_dump_indent(aTHX_ level, file, "SV = ");
1546
1547     /* Dump SV type */
1548
1549     if (type < SVt_LAST) {
1550         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1551
1552         if (type ==  SVt_NULL) {
1553             SvREFCNT_dec(d);
1554             return;
1555         }
1556     } else {
1557         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1558         SvREFCNT_dec(d);
1559         return;
1560     }
1561
1562     /* Dump general SV fields */
1563
1564     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1565          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1566          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1567         || (type == SVt_IV && !SvROK(sv))) {
1568         if (SvIsUV(sv)
1569 #ifdef PERL_OLD_COPY_ON_WRITE
1570                        || SvIsCOW(sv)
1571 #endif
1572                                      )
1573             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1574         else
1575             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1576 #ifdef PERL_OLD_COPY_ON_WRITE
1577         if (SvIsCOW_shared_hash(sv))
1578             PerlIO_printf(file, "  (HASH)");
1579         else if (SvIsCOW_normal(sv))
1580             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1581 #endif
1582         PerlIO_putc(file, '\n');
1583     }
1584
1585     if ((type == SVt_PVNV || type == SVt_PVMG)
1586         && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1587         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1588                          (UV) COP_SEQ_RANGE_LOW(sv));
1589         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1590                          (UV) COP_SEQ_RANGE_HIGH(sv));
1591     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1592                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1593                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1594                || type == SVt_NV) {
1595         STORE_NUMERIC_LOCAL_SET_STANDARD();
1596         /* %Vg doesn't work? --jhi */
1597 #ifdef USE_LONG_DOUBLE
1598         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1599 #else
1600         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1601 #endif
1602         RESTORE_NUMERIC_LOCAL();
1603     }
1604
1605     if (SvROK(sv)) {
1606         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1607         if (nest < maxnest)
1608             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1609     }
1610
1611     if (type < SVt_PV) {
1612         SvREFCNT_dec(d);
1613         return;
1614     }
1615
1616     if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1617         if (SvPVX_const(sv)) {
1618             STRLEN delta;
1619             if (SvOOK(sv)) {
1620                 SvOOK_offset(sv, delta);
1621                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1622                                  (UV) delta);
1623             } else {
1624                 delta = 0;
1625             }
1626             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1627             if (SvOOK(sv)) {
1628                 PerlIO_printf(file, "( %s . ) ",
1629                               pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1630                                          pvlim));
1631             }
1632             PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1633             if (SvUTF8(sv)) /* the 6?  \x{....} */
1634                 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1635             PerlIO_printf(file, "\n");
1636             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1637             Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
1638         }
1639         else
1640             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1641     }
1642
1643     if (type >= SVt_PVMG) {
1644         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1645             HV * const ost = SvOURSTASH(sv);
1646             if (ost)
1647                 do_hv_dump(level, file, "  OURSTASH", ost);
1648         } else {
1649             if (SvMAGIC(sv))
1650                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1651         }
1652         if (SvSTASH(sv))
1653             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1654
1655         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1656             Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
1657             Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1658             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1659         }
1660     }
1661
1662     /* Dump type-specific SV fields */
1663
1664     switch (type) {
1665     case SVt_PVAV:
1666         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1667         if (AvARRAY(sv) != AvALLOC(sv)) {
1668             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1669             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1670         }
1671         else
1672             PerlIO_putc(file, '\n');
1673         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1674         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1675         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1676         sv_setpvs(d, "");
1677         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1678         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1679         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1680                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1681         if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1682             int count;
1683             for (count = 0; count <=  av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1684                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1685
1686                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1687                 if (elt)
1688                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1689             }
1690         }
1691         break;
1692     case SVt_PVHV:
1693         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1694         if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1695             /* Show distribution of HEs in the ARRAY */
1696             int freq[200];
1697 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1698             int i;
1699             int max = 0;
1700             U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1701             NV theoret, sum = 0;
1702
1703             PerlIO_printf(file, "  (");
1704             Zero(freq, FREQ_MAX + 1, int);
1705             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1706                 HE* h;
1707                 int count = 0;
1708                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1709                     count++;
1710                 if (count > FREQ_MAX)
1711                     count = FREQ_MAX;
1712                 freq[count]++;
1713                 if (max < count)
1714                     max = count;
1715             }
1716             for (i = 0; i <= max; i++) {
1717                 if (freq[i]) {
1718                     PerlIO_printf(file, "%d%s:%d", i,
1719                                   (i == FREQ_MAX) ? "+" : "",
1720                                   freq[i]);
1721                     if (i != max)
1722                         PerlIO_printf(file, ", ");
1723                 }
1724             }
1725             PerlIO_putc(file, ')');
1726             /* The "quality" of a hash is defined as the total number of
1727                comparisons needed to access every element once, relative
1728                to the expected number needed for a random hash.
1729
1730                The total number of comparisons is equal to the sum of
1731                the squares of the number of entries in each bucket.
1732                For a random hash of n keys into k buckets, the expected
1733                value is
1734                                 n + n(n-1)/2k
1735             */
1736
1737             for (i = max; i > 0; i--) { /* Precision: count down. */
1738                 sum += freq[i] * i * i;
1739             }
1740             while ((keys = keys >> 1))
1741                 pow2 = pow2 << 1;
1742             theoret = HvUSEDKEYS(sv);
1743             theoret += theoret * (theoret-1)/pow2;
1744             PerlIO_putc(file, '\n');
1745             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1746         }
1747         PerlIO_putc(file, '\n');
1748         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1749         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1750         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1751         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1752         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1753         {
1754             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1755             if (mg && mg->mg_obj) {
1756                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1757             }
1758         }
1759         {
1760             const char * const hvname = HvNAME_get(sv);
1761             if (hvname)
1762                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1763         }
1764         if (SvOOK(sv)) {
1765             AV * const backrefs
1766                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1767             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1768             if (HvAUX(sv)->xhv_name_count)
1769                 Perl_dump_indent(aTHX_
1770                  level, file, "  NAMECOUNT = %"IVdf"\n",
1771                  (IV)HvAUX(sv)->xhv_name_count
1772                 );
1773             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1774                 const I32 count = HvAUX(sv)->xhv_name_count;
1775                 if (count) {
1776                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1777                     /* The starting point is the first element if count is
1778                        positive and the second element if count is negative. */
1779                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1780                         + (count < 0 ? 1 : 0);
1781                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1782                         + (count < 0 ? -count : count);
1783                     while (hekp < endp) {
1784                         if (*hekp) {
1785                             sv_catpvs(names, ", \"");
1786                             sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1787                             sv_catpvs(names, "\"");
1788                         } else {
1789                             /* This should never happen. */
1790                             sv_catpvs(names, ", (null)");
1791                         }
1792                         ++hekp;
1793                     }
1794                     Perl_dump_indent(aTHX_
1795                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1796                     );
1797                 }
1798                 else
1799                     Perl_dump_indent(aTHX_
1800                      level, file, "  ENAME = \"%s\"\n", HvENAME_get(sv)
1801                     );
1802             }
1803             if (backrefs) {
1804                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1805                                  PTR2UV(backrefs));
1806                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1807                            dumpops, pvlim);
1808             }
1809             if (meta) {
1810                 /* FIXME - mro_algs kflags can signal a UTF-8 name.  */
1811                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1812                                  (int)meta->mro_which->length,
1813                                  meta->mro_which->name,
1814                                  PTR2UV(meta->mro_which));
1815                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1816                                  (UV)meta->cache_gen);
1817                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1818                                  (UV)meta->pkg_gen);
1819                 if (meta->mro_linear_all) {
1820                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1821                                  PTR2UV(meta->mro_linear_all));
1822                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1823                            dumpops, pvlim);
1824                 }
1825                 if (meta->mro_linear_current) {
1826                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1827                                  PTR2UV(meta->mro_linear_current));
1828                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1829                            dumpops, pvlim);
1830                 }
1831                 if (meta->mro_nextmethod) {
1832                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1833                                  PTR2UV(meta->mro_nextmethod));
1834                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1835                            dumpops, pvlim);
1836                 }
1837                 if (meta->isa) {
1838                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1839                                  PTR2UV(meta->isa));
1840                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1841                            dumpops, pvlim);
1842                 }
1843             }
1844         }
1845         if (nest < maxnest) {
1846             HV * const hv = MUTABLE_HV(sv);
1847             STRLEN i;
1848             HE *he;
1849
1850             if (HvARRAY(hv)) {
1851                 int count = maxnest - nest;
1852                 for (i=0; i <= HvMAX(hv); i++) {
1853                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1854                         U32 hash;
1855                         SV * keysv;
1856                         const char * keypv;
1857                         SV * elt;
1858                 STRLEN len;
1859
1860                         if (count-- <= 0) goto DONEHV;
1861
1862                         hash = HeHASH(he);
1863                         keysv = hv_iterkeysv(he);
1864                         keypv = SvPV_const(keysv, len);
1865                         elt = HeVAL(he);
1866
1867                 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1868                 if (SvUTF8(keysv))
1869                     PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1870                         if (HvEITER_get(hv) == he)
1871                             PerlIO_printf(file, "[CURRENT] ");
1872                 if (HeKREHASH(he))
1873                     PerlIO_printf(file, "[REHASH] ");
1874                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1875                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1876             }
1877                 }
1878               DONEHV:;
1879             }
1880         }
1881         break;
1882
1883     case SVt_PVCV:
1884         if (CvAUTOLOAD(sv)) {
1885             STRLEN len;
1886             const char *const name =  SvPV_const(sv, len);
1887             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%.*s\"\n",
1888                              (int) len, name);
1889         }
1890         if (SvPOK(sv)) {
1891             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1892                              (int) CvPROTOLEN(sv), CvPROTO(sv));
1893         }
1894         /* FALL THROUGH */
1895     case SVt_PVFM:
1896         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1897         if (!CvISXSUB(sv)) {
1898             if (CvSTART(sv)) {
1899                 Perl_dump_indent(aTHX_ level, file,
1900                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1901                                  PTR2UV(CvSTART(sv)),
1902                                  (IV)sequence_num(CvSTART(sv)));
1903             }
1904             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1905                              PTR2UV(CvROOT(sv)));
1906             if (CvROOT(sv) && dumpops) {
1907                 do_op_dump(level+1, file, CvROOT(sv));
1908             }
1909         } else {
1910             SV * const constant = cv_const_sv((const CV *)sv);
1911
1912             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1913
1914             if (constant) {
1915                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1916                                  " (CONST SV)\n",
1917                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1918                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1919                            pvlim);
1920             } else {
1921                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1922                                  (IV)CvXSUBANY(sv).any_i32);
1923             }
1924         }
1925         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1926         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1927         if (type == SVt_PVCV)
1928             Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1929         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1930         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1931         if (type == SVt_PVFM)
1932             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
1933         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1934         if (nest < maxnest) {
1935             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1936         }
1937         {
1938             const CV * const outside = CvOUTSIDE(sv);
1939             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1940                         PTR2UV(outside),
1941                         (!outside ? "null"
1942                          : CvANON(outside) ? "ANON"
1943                          : (outside == PL_main_cv) ? "MAIN"
1944                          : CvUNIQUE(outside) ? "UNIQUE"
1945                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1946         }
1947         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1948             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1949         break;
1950
1951     case SVt_PVGV:
1952     case SVt_PVLV:
1953         if (type == SVt_PVLV) {
1954             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
1955             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1956             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1957             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1958             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
1959             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1960                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1961                     dumpops, pvlim);
1962         }
1963         if (!isGV_with_GP(sv))
1964             break;
1965         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
1966         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1967         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
1968         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1969         if (!GvGP(sv))
1970             break;
1971         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1972         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1973         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1974         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
1975         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1976         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1977         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1978         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1979         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
1980         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
1981         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1982         do_gv_dump (level, file, "    EGV", GvEGV(sv));
1983         break;
1984     case SVt_PVIO:
1985         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1986         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1987         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1988         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
1989         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1990         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1991         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1992         if (IoTOP_NAME(sv))
1993             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1994         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1995             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
1996         else {
1997             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
1998                              PTR2UV(IoTOP_GV(sv)));
1999             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2000                         maxnest, dumpops, pvlim);
2001         }
2002         /* Source filters hide things that are not GVs in these three, so let's
2003            be careful out there.  */
2004         if (IoFMT_NAME(sv))
2005             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2006         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2007             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2008         else {
2009             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2010                              PTR2UV(IoFMT_GV(sv)));
2011             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2012                         maxnest, dumpops, pvlim);
2013         }
2014         if (IoBOTTOM_NAME(sv))
2015             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2016         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2017             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2018         else {
2019             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2020                              PTR2UV(IoBOTTOM_GV(sv)));
2021             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2022                         maxnest, dumpops, pvlim);
2023         }
2024         if (isPRINT(IoTYPE(sv)))
2025             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2026         else
2027             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2028         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2029         break;
2030     case SVt_REGEXP:
2031         {
2032             struct regexp * const r = (struct regexp *)SvANY(sv);
2033             flags = RX_EXTFLAGS((REGEXP*)sv);
2034             sv_setpv(d,"");
2035             append_flags(d, flags, regexp_flags_names);
2036             if (*(SvEND(d) - 1) == ',') {
2037                 SvCUR_set(d, SvCUR(d) - 1);
2038                 SvPVX(d)[SvCUR(d)] = '\0';
2039             }
2040             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2041                                 (UV)flags, SvPVX_const(d));
2042             Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2043                                 (UV)(r->intflags));
2044             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2045                                 (UV)(r->nparens));
2046             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2047                                 (UV)(r->lastparen));
2048             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2049                                 (UV)(r->lastcloseparen));
2050             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2051                                 (IV)(r->minlen));
2052             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2053                                 (IV)(r->minlenret));
2054             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2055                                 (UV)(r->gofs));
2056             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2057                                 (UV)(r->pre_prefix));
2058             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2059                                 (IV)(r->sublen));
2060             if (r->subbeg)
2061                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2062                             PTR2UV(r->subbeg),
2063                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2064             else
2065                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2066             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf"\n",
2067                                 PTR2UV(r->engine));
2068             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2069                                 PTR2UV(r->mother_re));
2070             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2071                                 PTR2UV(r->paren_names));
2072             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2073                                 PTR2UV(r->substrs));
2074             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2075                                 PTR2UV(r->pprivate));
2076             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2077                                 PTR2UV(r->offs));
2078             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2079                                 PTR2UV(r->qr_anoncv));
2080 #ifdef PERL_OLD_COPY_ON_WRITE
2081             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2082                                 PTR2UV(r->saved_copy));
2083 #endif
2084         }
2085         break;
2086     }
2087     SvREFCNT_dec(d);
2088 }
2089
2090 void
2091 Perl_sv_dump(pTHX_ SV *sv)
2092 {
2093     dVAR;
2094
2095     PERL_ARGS_ASSERT_SV_DUMP;
2096
2097     if (SvROK(sv))
2098         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2099     else
2100         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2101 }
2102
2103 int
2104 Perl_runops_debug(pTHX)
2105 {
2106     dVAR;
2107     if (!PL_op) {
2108         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2109         return 0;
2110     }
2111
2112     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2113     do {
2114         if (PL_debug) {
2115             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2116                 PerlIO_printf(Perl_debug_log,
2117                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2118                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2119                               PTR2UV(*PL_watchaddr));
2120             if (DEBUG_s_TEST_) {
2121                 if (DEBUG_v_TEST_) {
2122                     PerlIO_printf(Perl_debug_log, "\n");
2123                     deb_stack_all();
2124                 }
2125                 else
2126                     debstack();
2127             }
2128
2129
2130             if (DEBUG_t_TEST_) debop(PL_op);
2131             if (DEBUG_P_TEST_) debprof(PL_op);
2132         }
2133     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2134     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2135
2136     TAINT_NOT;
2137     return 0;
2138 }
2139
2140 I32
2141 Perl_debop(pTHX_ const OP *o)
2142 {
2143     dVAR;
2144
2145     PERL_ARGS_ASSERT_DEBOP;
2146
2147     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2148         return 0;
2149
2150     Perl_deb(aTHX_ "%s", OP_NAME(o));
2151     switch (o->op_type) {
2152     case OP_CONST:
2153     case OP_HINTSEVAL:
2154         /* With ITHREADS, consts are stored in the pad, and the right pad
2155          * may not be active here, so check.
2156          * Looks like only during compiling the pads are illegal.
2157          */
2158 #ifdef USE_ITHREADS
2159         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2160 #endif
2161             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2162         break;
2163     case OP_GVSV:
2164     case OP_GV:
2165         if (cGVOPo_gv) {
2166             SV * const sv = newSV(0);
2167 #ifdef PERL_MAD
2168             /* FIXME - is this making unwarranted assumptions about the
2169                UTF-8 cleanliness of the dump file handle?  */
2170             SvUTF8_on(sv);
2171 #endif
2172             gv_fullname3(sv, cGVOPo_gv, NULL);
2173             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2174             SvREFCNT_dec(sv);
2175         }
2176         else
2177             PerlIO_printf(Perl_debug_log, "(NULL)");
2178         break;
2179     case OP_PADSV:
2180     case OP_PADAV:
2181     case OP_PADHV:
2182         {
2183         /* print the lexical's name */
2184         CV * const cv = deb_curcv(cxstack_ix);
2185         SV *sv;
2186         if (cv) {
2187             AV * const padlist = CvPADLIST(cv);
2188             AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2189             sv = *av_fetch(comppad, o->op_targ, FALSE);
2190         } else
2191             sv = NULL;
2192         if (sv)
2193             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2194         else
2195             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2196         }
2197         break;
2198     default:
2199         break;
2200     }
2201     PerlIO_printf(Perl_debug_log, "\n");
2202     return 0;
2203 }
2204
2205 STATIC CV*
2206 S_deb_curcv(pTHX_ const I32 ix)
2207 {
2208     dVAR;
2209     const PERL_CONTEXT * const cx = &cxstack[ix];
2210     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2211         return cx->blk_sub.cv;
2212     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2213         return cx->blk_eval.cv;
2214     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2215         return PL_main_cv;
2216     else if (ix <= 0)
2217         return NULL;
2218     else
2219         return deb_curcv(ix - 1);
2220 }
2221
2222 void
2223 Perl_watch(pTHX_ char **addr)
2224 {
2225     dVAR;
2226
2227     PERL_ARGS_ASSERT_WATCH;
2228
2229     PL_watchaddr = addr;
2230     PL_watchok = *addr;
2231     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2232         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2233 }
2234
2235 STATIC void
2236 S_debprof(pTHX_ const OP *o)
2237 {
2238     dVAR;
2239
2240     PERL_ARGS_ASSERT_DEBPROF;
2241
2242     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2243         return;
2244     if (!PL_profiledata)
2245         Newxz(PL_profiledata, MAXO, U32);
2246     ++PL_profiledata[o->op_type];
2247 }
2248
2249 void
2250 Perl_debprofdump(pTHX)
2251 {
2252     dVAR;
2253     unsigned i;
2254     if (!PL_profiledata)
2255         return;
2256     for (i = 0; i < MAXO; i++) {
2257         if (PL_profiledata[i])
2258             PerlIO_printf(Perl_debug_log,
2259                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2260                                        PL_op_name[i]);
2261     }
2262 }
2263
2264 #ifdef PERL_MAD
2265 /*
2266  *    XML variants of most of the above routines
2267  */
2268
2269 STATIC void
2270 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2271 {
2272     va_list args;
2273
2274     PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2275
2276     PerlIO_printf(file, "\n    ");
2277     va_start(args, pat);
2278     xmldump_vindent(level, file, pat, &args);
2279     va_end(args);
2280 }
2281
2282
2283 void
2284 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2285 {
2286     va_list args;
2287     PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2288     va_start(args, pat);
2289     xmldump_vindent(level, file, pat, &args);
2290     va_end(args);
2291 }
2292
2293 void
2294 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2295 {
2296     PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2297
2298     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2299     PerlIO_vprintf(file, pat, *args);
2300 }
2301
2302 void
2303 Perl_xmldump_all(pTHX)
2304 {
2305     xmldump_all_perl(FALSE);
2306 }
2307
2308 void
2309 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2310 {
2311     PerlIO_setlinebuf(PL_xmlfp);
2312     if (PL_main_root)
2313         op_xmldump(PL_main_root);
2314     /* someday we might call this, when it outputs XML: */
2315     /* xmldump_packsubs_perl(PL_defstash, justperl); */
2316     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2317         PerlIO_close(PL_xmlfp);
2318     PL_xmlfp = 0;
2319 }
2320
2321 void
2322 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2323 {
2324     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2325     xmldump_packsubs_perl(stash, FALSE);
2326 }
2327
2328 void
2329 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2330 {
2331     I32 i;
2332     HE  *entry;
2333
2334     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2335
2336     if (!HvARRAY(stash))
2337         return;
2338     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2339         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2340             GV *gv = MUTABLE_GV(HeVAL(entry));
2341             HV *hv;
2342             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2343                 continue;
2344             if (GvCVu(gv))
2345                 xmldump_sub_perl(gv, justperl);
2346             if (GvFORM(gv))
2347                 xmldump_form(gv);
2348             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2349                 && (hv = GvHV(gv)) && hv != PL_defstash)
2350                 xmldump_packsubs_perl(hv, justperl);    /* nested package */
2351         }
2352     }
2353 }
2354
2355 void
2356 Perl_xmldump_sub(pTHX_ const GV *gv)
2357 {
2358     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2359     xmldump_sub_perl(gv, FALSE);
2360 }
2361
2362 void
2363 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2364 {
2365     SV * sv;
2366
2367     PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2368
2369     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2370         return;
2371
2372     sv = sv_newmortal();
2373     gv_fullname3(sv, gv, NULL);
2374     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2375     if (CvXSUB(GvCV(gv)))
2376         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2377             PTR2UV(CvXSUB(GvCV(gv))),
2378             (int)CvXSUBANY(GvCV(gv)).any_i32);
2379     else if (CvROOT(GvCV(gv)))
2380         op_xmldump(CvROOT(GvCV(gv)));
2381     else
2382         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2383 }
2384
2385 void
2386 Perl_xmldump_form(pTHX_ const GV *gv)
2387 {
2388     SV * const sv = sv_newmortal();
2389
2390     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2391
2392     gv_fullname3(sv, gv, NULL);
2393     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2394     if (CvROOT(GvFORM(gv)))
2395         op_xmldump(CvROOT(GvFORM(gv)));
2396     else
2397         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2398 }
2399
2400 void
2401 Perl_xmldump_eval(pTHX)
2402 {
2403     op_xmldump(PL_eval_root);
2404 }
2405
2406 char *
2407 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2408 {
2409     PERL_ARGS_ASSERT_SV_CATXMLSV;
2410     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2411 }
2412
2413 char *
2414 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2415 {
2416     PERL_ARGS_ASSERT_SV_CATXMLPV;
2417     return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2418 }
2419
2420 char *
2421 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2422 {
2423     unsigned int c;
2424     const char * const e = pv + len;
2425     const char * const start = pv;
2426     STRLEN dsvcur;
2427     STRLEN cl;
2428
2429     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2430
2431     sv_catpvs(dsv,"");
2432     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2433
2434   retry:
2435     while (pv < e) {
2436         if (utf8) {
2437             c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2438             if (cl == 0) {
2439                 SvCUR(dsv) = dsvcur;
2440                 pv = start;
2441                 utf8 = 0;
2442                 goto retry;
2443             }
2444         }
2445         else
2446             c = (*pv & 255);
2447
2448         switch (c) {
2449         case 0x00:
2450         case 0x01:
2451         case 0x02:
2452         case 0x03:
2453         case 0x04:
2454         case 0x05:
2455         case 0x06:
2456         case 0x07:
2457         case 0x08:
2458         case 0x0b:
2459         case 0x0c:
2460         case 0x0e:
2461         case 0x0f:
2462         case 0x10:
2463         case 0x11:
2464         case 0x12:
2465         case 0x13:
2466         case 0x14:
2467         case 0x15:
2468         case 0x16:
2469         case 0x17:
2470         case 0x18:
2471         case 0x19:
2472         case 0x1a:
2473         case 0x1b:
2474         case 0x1c:
2475         case 0x1d:
2476         case 0x1e:
2477         case 0x1f:
2478         case 0x7f:
2479         case 0x80:
2480         case 0x81:
2481         case 0x82:
2482         case 0x83:
2483         case 0x84:
2484         case 0x86:
2485         case 0x87:
2486         case 0x88:
2487         case 0x89:
2488         case 0x90:
2489         case 0x91:
2490         case 0x92:
2491         case 0x93:
2492         case 0x94:
2493         case 0x95:
2494         case 0x96:
2495         case 0x97:
2496         case 0x98:
2497         case 0x99:
2498         case 0x9a:
2499         case 0x9b:
2500         case 0x9c:
2501         case 0x9d:
2502         case 0x9e:
2503         case 0x9f:
2504             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2505             break;
2506         case '<':
2507             sv_catpvs(dsv, "&lt;");
2508             break;
2509         case '>':
2510             sv_catpvs(dsv, "&gt;");
2511             break;
2512         case '&':
2513             sv_catpvs(dsv, "&amp;");
2514             break;
2515         case '"':
2516             sv_catpvs(dsv, "&#34;");
2517             break;
2518         default:
2519             if (c < 0xD800) {
2520                 if (c < 32 || c > 127) {
2521                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2522                 }
2523                 else {
2524                     const char string = (char) c;
2525                     sv_catpvn(dsv, &string, 1);
2526                 }
2527                 break;
2528             }
2529             if ((c >= 0xD800 && c <= 0xDB7F) ||
2530                 (c >= 0xDC00 && c <= 0xDFFF) ||
2531                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2532                  c > 0x10ffff)
2533                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2534             else
2535                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2536         }
2537
2538         if (utf8)
2539             pv += UTF8SKIP(pv);
2540         else
2541             pv++;
2542     }
2543
2544     return SvPVX(dsv);
2545 }
2546
2547 char *
2548 Perl_sv_xmlpeek(pTHX_ SV *sv)
2549 {
2550     SV * const t = sv_newmortal();
2551     STRLEN n_a;
2552     int unref = 0;
2553
2554     PERL_ARGS_ASSERT_SV_XMLPEEK;
2555
2556     sv_utf8_upgrade(t);
2557     sv_setpvs(t, "");
2558     /* retry: */
2559     if (!sv) {
2560         sv_catpv(t, "VOID=\"\"");
2561         goto finish;
2562     }
2563     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2564         sv_catpv(t, "WILD=\"\"");
2565         goto finish;
2566     }
2567     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2568         if (sv == &PL_sv_undef) {
2569             sv_catpv(t, "SV_UNDEF=\"1\"");
2570             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2571                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2572                 SvREADONLY(sv))
2573                 goto finish;
2574         }
2575         else if (sv == &PL_sv_no) {
2576             sv_catpv(t, "SV_NO=\"1\"");
2577             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2578                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2579                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2580                                   SVp_POK|SVp_NOK)) &&
2581                 SvCUR(sv) == 0 &&
2582                 SvNVX(sv) == 0.0)
2583                 goto finish;
2584         }
2585         else if (sv == &PL_sv_yes) {
2586             sv_catpv(t, "SV_YES=\"1\"");
2587             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2588                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2589                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2590                                   SVp_POK|SVp_NOK)) &&
2591                 SvCUR(sv) == 1 &&
2592                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2593                 SvNVX(sv) == 1.0)
2594                 goto finish;
2595         }
2596         else {
2597             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2598             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2599                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2600                 SvREADONLY(sv))
2601                 goto finish;
2602         }
2603         sv_catpv(t, " XXX=\"\" ");
2604     }
2605     else if (SvREFCNT(sv) == 0) {
2606         sv_catpv(t, " refcnt=\"0\"");
2607         unref++;
2608     }
2609     else if (DEBUG_R_TEST_) {
2610         int is_tmp = 0;
2611         I32 ix;
2612         /* is this SV on the tmps stack? */
2613         for (ix=PL_tmps_ix; ix>=0; ix--) {
2614             if (PL_tmps_stack[ix] == sv) {
2615                 is_tmp = 1;
2616                 break;
2617             }
2618         }
2619         if (SvREFCNT(sv) > 1)
2620             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2621                     is_tmp ? "T" : "");
2622         else if (is_tmp)
2623             sv_catpv(t, " DRT=\"<T>\"");
2624     }
2625
2626     if (SvROK(sv)) {
2627         sv_catpv(t, " ROK=\"\"");
2628     }
2629     switch (SvTYPE(sv)) {
2630     default:
2631         sv_catpv(t, " FREED=\"1\"");
2632         goto finish;
2633
2634     case SVt_NULL:
2635         sv_catpv(t, " UNDEF=\"1\"");
2636         goto finish;
2637     case SVt_IV:
2638         sv_catpv(t, " IV=\"");
2639         break;
2640     case SVt_NV:
2641         sv_catpv(t, " NV=\"");
2642         break;
2643     case SVt_PV:
2644         sv_catpv(t, " PV=\"");
2645         break;
2646     case SVt_PVIV:
2647         sv_catpv(t, " PVIV=\"");
2648         break;
2649     case SVt_PVNV:
2650         sv_catpv(t, " PVNV=\"");
2651         break;
2652     case SVt_PVMG:
2653         sv_catpv(t, " PVMG=\"");
2654         break;
2655     case SVt_PVLV:
2656         sv_catpv(t, " PVLV=\"");
2657         break;
2658     case SVt_PVAV:
2659         sv_catpv(t, " AV=\"");
2660         break;
2661     case SVt_PVHV:
2662         sv_catpv(t, " HV=\"");
2663         break;
2664     case SVt_PVCV:
2665         if (CvGV(sv))
2666             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2667         else
2668             sv_catpv(t, " CV=\"()\"");
2669         goto finish;
2670     case SVt_PVGV:
2671         sv_catpv(t, " GV=\"");
2672         break;
2673     case SVt_BIND:
2674         sv_catpv(t, " BIND=\"");
2675         break;
2676     case SVt_REGEXP:
2677         sv_catpv(t, " REGEXP=\"");
2678         break;
2679     case SVt_PVFM:
2680         sv_catpv(t, " FM=\"");
2681         break;
2682     case SVt_PVIO:
2683         sv_catpv(t, " IO=\"");
2684         break;
2685     }
2686
2687     if (SvPOKp(sv)) {
2688         if (SvPVX(sv)) {
2689             sv_catxmlsv(t, sv);
2690         }
2691     }
2692     else if (SvNOKp(sv)) {
2693         STORE_NUMERIC_LOCAL_SET_STANDARD();
2694         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2695         RESTORE_NUMERIC_LOCAL();
2696     }
2697     else if (SvIOKp(sv)) {
2698         if (SvIsUV(sv))
2699             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2700         else
2701             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2702     }
2703     else
2704         sv_catpv(t, "");
2705     sv_catpv(t, "\"");
2706
2707   finish:
2708     while (unref--)
2709         sv_catpv(t, ")");
2710     return SvPV(t, n_a);
2711 }
2712
2713 void
2714 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2715 {
2716     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2717
2718     if (!pm) {
2719         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2720         return;
2721     }
2722     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2723     level++;
2724     if (PM_GETRE(pm)) {
2725         REGEXP *const r = PM_GETRE(pm);
2726         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2727         sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2728         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2729              SvPVX(tmpsv));
2730         SvREFCNT_dec(tmpsv);
2731         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2732              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2733     }
2734     else
2735         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2736     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2737         SV * const tmpsv = pm_description(pm);
2738         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2739         SvREFCNT_dec(tmpsv);
2740     }
2741
2742     level--;
2743     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2744         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2745         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2746         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2747         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2748         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2749     }
2750     else
2751         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2752 }
2753
2754 void
2755 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2756 {
2757     do_pmop_xmldump(0, PL_xmlfp, pm);
2758 }
2759
2760 void
2761 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2762 {
2763     UV      seq;
2764     int     contents = 0;
2765
2766     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2767
2768     if (!o)
2769         return;
2770     seq = sequence_num(o);
2771     Perl_xmldump_indent(aTHX_ level, file,
2772         "<op_%s seq=\"%"UVuf" -> ",
2773              OP_NAME(o),
2774                       seq);
2775     level++;
2776     if (o->op_next)
2777         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2778                       sequence_num(o->op_next));
2779     else
2780         PerlIO_printf(file, "DONE\"");
2781
2782     if (o->op_targ) {
2783         if (o->op_type == OP_NULL)
2784         {
2785             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2786             if (o->op_targ == OP_NEXTSTATE)
2787             {
2788                 if (CopLINE(cCOPo))
2789                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2790                                      (UV)CopLINE(cCOPo));
2791                 if (CopSTASHPV(cCOPo))
2792                     PerlIO_printf(file, " package=\"%s\"",
2793                                      CopSTASHPV(cCOPo));
2794                 if (CopLABEL(cCOPo))
2795                     PerlIO_printf(file, " label=\"%s\"",
2796                                      CopLABEL(cCOPo));
2797             }
2798         }
2799         else
2800             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2801     }
2802 #ifdef DUMPADDR
2803     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2804 #endif
2805     if (o->op_flags) {
2806         SV * const tmpsv = newSVpvs("");
2807         switch (o->op_flags & OPf_WANT) {
2808         case OPf_WANT_VOID:
2809             sv_catpv(tmpsv, ",VOID");
2810             break;
2811         case OPf_WANT_SCALAR:
2812             sv_catpv(tmpsv, ",SCALAR");
2813             break;
2814         case OPf_WANT_LIST:
2815             sv_catpv(tmpsv, ",LIST");
2816             break;
2817         default:
2818             sv_catpv(tmpsv, ",UNKNOWN");
2819             break;
2820         }
2821         if (o->op_flags & OPf_KIDS)
2822             sv_catpv(tmpsv, ",KIDS");
2823         if (o->op_flags & OPf_PARENS)
2824             sv_catpv(tmpsv, ",PARENS");
2825         if (o->op_flags & OPf_STACKED)
2826             sv_catpv(tmpsv, ",STACKED");
2827         if (o->op_flags & OPf_REF)
2828             sv_catpv(tmpsv, ",REF");
2829         if (o->op_flags & OPf_MOD)
2830             sv_catpv(tmpsv, ",MOD");
2831         if (o->op_flags & OPf_SPECIAL)
2832             sv_catpv(tmpsv, ",SPECIAL");
2833         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2834         SvREFCNT_dec(tmpsv);
2835     }
2836     if (o->op_private) {
2837         SV * const tmpsv = newSVpvs("");
2838         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2839             if (o->op_private & OPpTARGET_MY)
2840                 sv_catpv(tmpsv, ",TARGET_MY");
2841         }
2842         else if (o->op_type == OP_LEAVESUB ||
2843                  o->op_type == OP_LEAVE ||
2844                  o->op_type == OP_LEAVESUBLV ||
2845                  o->op_type == OP_LEAVEWRITE) {
2846             if (o->op_private & OPpREFCOUNTED)
2847                 sv_catpv(tmpsv, ",REFCOUNTED");
2848         }
2849         else if (o->op_type == OP_AASSIGN) {
2850             if (o->op_private & OPpASSIGN_COMMON)
2851                 sv_catpv(tmpsv, ",COMMON");
2852         }
2853         else if (o->op_type == OP_SASSIGN) {
2854             if (o->op_private & OPpASSIGN_BACKWARDS)
2855                 sv_catpv(tmpsv, ",BACKWARDS");
2856         }
2857         else if (o->op_type == OP_TRANS) {
2858             if (o->op_private & OPpTRANS_SQUASH)
2859                 sv_catpv(tmpsv, ",SQUASH");
2860             if (o->op_private & OPpTRANS_DELETE)
2861                 sv_catpv(tmpsv, ",DELETE");
2862             if (o->op_private & OPpTRANS_COMPLEMENT)
2863                 sv_catpv(tmpsv, ",COMPLEMENT");
2864             if (o->op_private & OPpTRANS_IDENTICAL)
2865                 sv_catpv(tmpsv, ",IDENTICAL");
2866             if (o->op_private & OPpTRANS_GROWS)
2867                 sv_catpv(tmpsv, ",GROWS");
2868         }
2869         else if (o->op_type == OP_REPEAT) {
2870             if (o->op_private & OPpREPEAT_DOLIST)
2871                 sv_catpv(tmpsv, ",DOLIST");
2872         }
2873         else if (o->op_type == OP_ENTERSUB ||
2874                  o->op_type == OP_RV2SV ||
2875                  o->op_type == OP_GVSV ||
2876                  o->op_type == OP_RV2AV ||
2877                  o->op_type == OP_RV2HV ||
2878                  o->op_type == OP_RV2GV ||
2879                  o->op_type == OP_AELEM ||
2880                  o->op_type == OP_HELEM )
2881         {
2882             if (o->op_type == OP_ENTERSUB) {
2883                 if (o->op_private & OPpENTERSUB_AMPER)
2884                     sv_catpv(tmpsv, ",AMPER");
2885                 if (o->op_private & OPpENTERSUB_DB)
2886                     sv_catpv(tmpsv, ",DB");
2887                 if (o->op_private & OPpENTERSUB_HASTARG)
2888                     sv_catpv(tmpsv, ",HASTARG");
2889                 if (o->op_private & OPpENTERSUB_NOPAREN)
2890                     sv_catpv(tmpsv, ",NOPAREN");
2891                 if (o->op_private & OPpENTERSUB_INARGS)
2892                     sv_catpv(tmpsv, ",INARGS");
2893             }
2894             else {
2895                 switch (o->op_private & OPpDEREF) {
2896             case OPpDEREF_SV:
2897                 sv_catpv(tmpsv, ",SV");
2898                 break;
2899             case OPpDEREF_AV:
2900                 sv_catpv(tmpsv, ",AV");
2901                 break;
2902             case OPpDEREF_HV:
2903                 sv_catpv(tmpsv, ",HV");
2904                 break;
2905             }
2906                 if (o->op_private & OPpMAYBE_LVSUB)
2907                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2908             }
2909             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2910                 if (o->op_private & OPpLVAL_DEFER)
2911                     sv_catpv(tmpsv, ",LVAL_DEFER");
2912             }
2913             else {
2914                 if (o->op_private & HINT_STRICT_REFS)
2915                     sv_catpv(tmpsv, ",STRICT_REFS");
2916                 if (o->op_private & OPpOUR_INTRO)
2917                     sv_catpv(tmpsv, ",OUR_INTRO");
2918             }
2919         }
2920         else if (o->op_type == OP_CONST) {
2921             if (o->op_private & OPpCONST_BARE)
2922                 sv_catpv(tmpsv, ",BARE");
2923             if (o->op_private & OPpCONST_STRICT)
2924                 sv_catpv(tmpsv, ",STRICT");
2925             if (o->op_private & OPpCONST_ENTERED)
2926                 sv_catpv(tmpsv, ",ENTERED");
2927             if (o->op_private & OPpCONST_FOLDED)
2928                 sv_catpv(tmpsv, ",FOLDED");
2929         }
2930         else if (o->op_type == OP_FLIP) {
2931             if (o->op_private & OPpFLIP_LINENUM)
2932                 sv_catpv(tmpsv, ",LINENUM");
2933         }
2934         else if (o->op_type == OP_FLOP) {
2935             if (o->op_private & OPpFLIP_LINENUM)
2936                 sv_catpv(tmpsv, ",LINENUM");
2937         }
2938         else if (o->op_type == OP_RV2CV) {
2939             if (o->op_private & OPpLVAL_INTRO)
2940                 sv_catpv(tmpsv, ",INTRO");
2941         }
2942         else if (o->op_type == OP_GV) {
2943             if (o->op_private & OPpEARLY_CV)
2944                 sv_catpv(tmpsv, ",EARLY_CV");
2945         }
2946         else if (o->op_type == OP_LIST) {
2947             if (o->op_private & OPpLIST_GUESSED)
2948                 sv_catpv(tmpsv, ",GUESSED");
2949         }
2950         else if (o->op_type == OP_DELETE) {
2951             if (o->op_private & OPpSLICE)
2952                 sv_catpv(tmpsv, ",SLICE");
2953         }
2954         else if (o->op_type == OP_EXISTS) {
2955             if (o->op_private & OPpEXISTS_SUB)
2956                 sv_catpv(tmpsv, ",EXISTS_SUB");
2957         }
2958         else if (o->op_type == OP_SORT) {
2959             if (o->op_private & OPpSORT_NUMERIC)
2960                 sv_catpv(tmpsv, ",NUMERIC");
2961             if (o->op_private & OPpSORT_INTEGER)
2962                 sv_catpv(tmpsv, ",INTEGER");
2963             if (o->op_private & OPpSORT_REVERSE)
2964                 sv_catpv(tmpsv, ",REVERSE");
2965         }
2966         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2967             if (o->op_private & OPpOPEN_IN_RAW)
2968                 sv_catpv(tmpsv, ",IN_RAW");
2969             if (o->op_private & OPpOPEN_IN_CRLF)
2970                 sv_catpv(tmpsv, ",IN_CRLF");
2971             if (o->op_private & OPpOPEN_OUT_RAW)
2972                 sv_catpv(tmpsv, ",OUT_RAW");
2973             if (o->op_private & OPpOPEN_OUT_CRLF)
2974                 sv_catpv(tmpsv, ",OUT_CRLF");
2975         }
2976         else if (o->op_type == OP_EXIT) {
2977             if (o->op_private & OPpEXIT_VMSISH)
2978                 sv_catpv(tmpsv, ",EXIT_VMSISH");
2979             if (o->op_private & OPpHUSH_VMSISH)
2980                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2981         }
2982         else if (o->op_type == OP_DIE) {
2983             if (o->op_private & OPpHUSH_VMSISH)
2984                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2985         }
2986         else if (PL_check[o->op_type] != Perl_ck_ftst) {
2987             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2988                 sv_catpv(tmpsv, ",FT_ACCESS");
2989             if (o->op_private & OPpFT_STACKED)
2990                 sv_catpv(tmpsv, ",FT_STACKED");
2991         }
2992         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2993             sv_catpv(tmpsv, ",INTRO");
2994         if (SvCUR(tmpsv))
2995             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2996         SvREFCNT_dec(tmpsv);
2997     }
2998
2999     switch (o->op_type) {
3000     case OP_AELEMFAST:
3001         if (o->op_flags & OPf_SPECIAL) {
3002             break;
3003         }
3004     case OP_GVSV:
3005     case OP_GV:
3006 #ifdef USE_ITHREADS
3007         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3008 #else
3009         if (cSVOPo->op_sv) {
3010             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3011             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3012             char *s;
3013             STRLEN len;
3014             ENTER;
3015             SAVEFREESV(tmpsv1);
3016             SAVEFREESV(tmpsv2);
3017             gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3018             s = SvPV(tmpsv1,len);
3019             sv_catxmlpvn(tmpsv2, s, len, 1);
3020             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3021             LEAVE;
3022         }
3023         else
3024             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3025 #endif
3026         break;
3027     case OP_CONST:
3028     case OP_HINTSEVAL:
3029     case OP_METHOD_NAMED:
3030 #ifndef USE_ITHREADS
3031         /* with ITHREADS, consts are stored in the pad, and the right pad
3032          * may not be active here, so skip */
3033         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3034 #endif
3035         break;
3036     case OP_ANONCODE:
3037         if (!contents) {
3038             contents = 1;
3039             PerlIO_printf(file, ">\n");
3040         }
3041         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3042         break;
3043     case OP_NEXTSTATE:
3044     case OP_DBSTATE:
3045         if (CopLINE(cCOPo))
3046             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3047                              (UV)CopLINE(cCOPo));
3048         if (CopSTASHPV(cCOPo))
3049             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3050                              CopSTASHPV(cCOPo));
3051         if (CopLABEL(cCOPo))
3052             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3053                              CopLABEL(cCOPo));
3054         break;
3055     case OP_ENTERLOOP:
3056         S_xmldump_attr(aTHX_ level, file, "redo=\"");
3057         if (cLOOPo->op_redoop)
3058             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3059         else
3060             PerlIO_printf(file, "DONE\"");
3061         S_xmldump_attr(aTHX_ level, file, "next=\"");
3062         if (cLOOPo->op_nextop)
3063             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3064         else
3065             PerlIO_printf(file, "DONE\"");
3066         S_xmldump_attr(aTHX_ level, file, "last=\"");
3067         if (cLOOPo->op_lastop)
3068             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3069         else
3070             PerlIO_printf(file, "DONE\"");
3071         break;
3072     case OP_COND_EXPR:
3073     case OP_RANGE:
3074     case OP_MAPWHILE:
3075     case OP_GREPWHILE:
3076     case OP_OR:
3077     case OP_AND:
3078         S_xmldump_attr(aTHX_ level, file, "other=\"");
3079         if (cLOGOPo->op_other)
3080             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3081         else
3082             PerlIO_printf(file, "DONE\"");
3083         break;
3084     case OP_LEAVE:
3085     case OP_LEAVEEVAL:
3086     case OP_LEAVESUB:
3087     case OP_LEAVESUBLV:
3088     case OP_LEAVEWRITE:
3089     case OP_SCOPE:
3090         if (o->op_private & OPpREFCOUNTED)
3091             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3092         break;
3093     default:
3094         break;
3095     }
3096
3097     if (PL_madskills && o->op_madprop) {
3098         char prevkey = '\0';
3099         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3100         const MADPROP* mp = o->op_madprop;
3101
3102         if (!contents) {
3103             contents = 1;
3104             PerlIO_printf(file, ">\n");
3105         }
3106         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3107         level++;
3108         while (mp) {
3109             char tmp = mp->mad_key;
3110             sv_setpvs(tmpsv,"\"");
3111             if (tmp)
3112                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3113             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3114                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3115             else
3116                 prevkey = tmp;
3117             sv_catpv(tmpsv, "\"");
3118             switch (mp->mad_type) {
3119             case MAD_NULL:
3120                 sv_catpv(tmpsv, "NULL");
3121                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3122                 break;
3123             case MAD_PV:
3124                 sv_catpv(tmpsv, " val=\"");
3125                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3126                 sv_catpv(tmpsv, "\"");
3127                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3128                 break;
3129             case MAD_SV:
3130                 sv_catpv(tmpsv, " val=\"");
3131                 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3132                 sv_catpv(tmpsv, "\"");
3133                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3134                 break;
3135             case MAD_OP:
3136                 if ((OP*)mp->mad_val) {
3137                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3138                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3139                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3140                 }
3141                 break;
3142             default:
3143                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3144                 break;
3145             }
3146             mp = mp->mad_next;
3147         }
3148         level--;
3149         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3150
3151         SvREFCNT_dec(tmpsv);
3152     }
3153
3154     switch (o->op_type) {
3155     case OP_PUSHRE:
3156     case OP_MATCH:
3157     case OP_QR:
3158     case OP_SUBST:
3159         if (!contents) {
3160             contents = 1;
3161             PerlIO_printf(file, ">\n");
3162         }
3163         do_pmop_xmldump(level, file, cPMOPo);
3164         break;
3165     default:
3166         break;
3167     }
3168
3169     if (o->op_flags & OPf_KIDS) {
3170         OP *kid;
3171         if (!contents) {
3172             contents = 1;
3173             PerlIO_printf(file, ">\n");
3174         }
3175         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3176             do_op_xmldump(level, file, kid);
3177     }
3178
3179     if (contents)
3180         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3181     else
3182         PerlIO_printf(file, " />\n");
3183 }
3184
3185 void
3186 Perl_op_xmldump(pTHX_ const OP *o)
3187 {
3188     PERL_ARGS_ASSERT_OP_XMLDUMP;
3189
3190     do_op_xmldump(0, PL_xmlfp, o);
3191 }
3192 #endif
3193
3194 /*
3195  * Local variables:
3196  * c-indentation-style: bsd
3197  * c-basic-offset: 4
3198  * indent-tabs-mode: nil
3199  * End:
3200  *
3201  * ex: set ts=8 sts=4 sw=4 et:
3202  */