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