This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Provide the names of the magic vtables in PL_magic_vtable_names[].
[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+readsize < 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             if (v >= PL_magic_vtables
1294                 && v < PL_magic_vtables + magic_vtable_max) {
1295                 const U32 i = v - PL_magic_vtables;
1296                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1297             }
1298             else
1299                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1300         }
1301         else
1302             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1303
1304         if (mg->mg_private)
1305             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1306
1307         {
1308             int n;
1309             const char *name = NULL;
1310             for (n = 0; magic_names[n].name; n++) {
1311                 if (mg->mg_type == magic_names[n].type) {
1312                     name = magic_names[n].name;
1313                     break;
1314                 }
1315             }
1316             if (name)
1317                 Perl_dump_indent(aTHX_ level, file,
1318                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1319             else
1320                 Perl_dump_indent(aTHX_ level, file,
1321                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1322         }
1323
1324         if (mg->mg_flags) {
1325             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1326             if (mg->mg_type == PERL_MAGIC_envelem &&
1327                 mg->mg_flags & MGf_TAINTEDDIR)
1328                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1329             if (mg->mg_type == PERL_MAGIC_regex_global &&
1330                 mg->mg_flags & MGf_MINMATCH)
1331                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1332             if (mg->mg_flags & MGf_REFCOUNTED)
1333                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1334             if (mg->mg_flags & MGf_GSKIP)
1335                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1336             if (mg->mg_flags & MGf_COPY)
1337                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1338             if (mg->mg_flags & MGf_DUP)
1339                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1340             if (mg->mg_flags & MGf_LOCAL)
1341                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1342         }
1343         if (mg->mg_obj) {
1344             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1345                 PTR2UV(mg->mg_obj));
1346             if (mg->mg_type == PERL_MAGIC_qr) {
1347                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1348                 SV * const dsv = sv_newmortal();
1349                 const char * const s
1350                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1351                     60, NULL, NULL,
1352                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1353                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1354                 );
1355                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1356                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1357                         (IV)RX_REFCNT(re));
1358             }
1359             if (mg->mg_flags & MGf_REFCOUNTED)
1360                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1361         }
1362         if (mg->mg_len)
1363             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1364         if (mg->mg_ptr) {
1365             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1366             if (mg->mg_len >= 0) {
1367                 if (mg->mg_type != PERL_MAGIC_utf8) {
1368                     SV * const sv = newSVpvs("");
1369                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1370                     SvREFCNT_dec(sv);
1371                 }
1372             }
1373             else if (mg->mg_len == HEf_SVKEY) {
1374                 PerlIO_puts(file, " => HEf_SVKEY\n");
1375                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1376                            maxnest, dumpops, pvlim); /* MG is already +1 */
1377                 continue;
1378             }
1379             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1380             else
1381                 PerlIO_puts(
1382                   file,
1383                  " ???? - " __FILE__
1384                  " does not know how to handle this MG_LEN"
1385                 );
1386             PerlIO_putc(file, '\n');
1387         }
1388         if (mg->mg_type == PERL_MAGIC_utf8) {
1389             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1390             if (cache) {
1391                 IV i;
1392                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1393                     Perl_dump_indent(aTHX_ level, file,
1394                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1395                                      i,
1396                                      (UV)cache[i * 2],
1397                                      (UV)cache[i * 2 + 1]);
1398             }
1399         }
1400     }
1401 }
1402
1403 void
1404 Perl_magic_dump(pTHX_ const MAGIC *mg)
1405 {
1406     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1407 }
1408
1409 void
1410 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1411 {
1412     const char *hvname;
1413
1414     PERL_ARGS_ASSERT_DO_HV_DUMP;
1415
1416     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1417     if (sv && (hvname = HvNAME_get(sv)))
1418     {
1419         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1420            name which quite legally could contain insane things like tabs, newlines, nulls or
1421            other scary crap - this should produce sane results - except maybe for unicode package
1422            names - but we will wait for someone to file a bug on that - demerphq */
1423         SV * const tmpsv = newSVpvs("");
1424         PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1425     }
1426     else
1427         PerlIO_putc(file, '\n');
1428 }
1429
1430 void
1431 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1432 {
1433     PERL_ARGS_ASSERT_DO_GV_DUMP;
1434
1435     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1436     if (sv && GvNAME(sv))
1437         PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1438     else
1439         PerlIO_putc(file, '\n');
1440 }
1441
1442 void
1443 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1444 {
1445     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1446
1447     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1448     if (sv && GvNAME(sv)) {
1449         const char *hvname;
1450         PerlIO_printf(file, "\t\"");
1451         if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1452             PerlIO_printf(file, "%s\" :: \"", hvname);
1453         PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1454     }
1455     else
1456         PerlIO_putc(file, '\n');
1457 }
1458
1459 const struct flag_to_name first_sv_flags_names[] = {
1460     {SVs_TEMP, "TEMP,"},
1461     {SVs_OBJECT, "OBJECT,"},
1462     {SVs_GMG, "GMG,"},
1463     {SVs_SMG, "SMG,"},
1464     {SVs_RMG, "RMG,"},
1465     {SVf_IOK, "IOK,"},
1466     {SVf_NOK, "NOK,"},
1467     {SVf_POK, "POK,"}
1468 };
1469
1470 const struct flag_to_name second_sv_flags_names[] = {
1471     {SVf_OOK, "OOK,"},
1472     {SVf_FAKE, "FAKE,"},
1473     {SVf_READONLY, "READONLY,"},
1474     {SVf_BREAK, "BREAK,"},
1475     {SVf_AMAGIC, "OVERLOAD,"},
1476     {SVp_IOK, "pIOK,"},
1477     {SVp_NOK, "pNOK,"},
1478     {SVp_POK, "pPOK,"}
1479 };
1480
1481 const struct flag_to_name cv_flags_names[] = {
1482     {CVf_ANON, "ANON,"},
1483     {CVf_UNIQUE, "UNIQUE,"},
1484     {CVf_CLONE, "CLONE,"},
1485     {CVf_CLONED, "CLONED,"},
1486     {CVf_CONST, "CONST,"},
1487     {CVf_NODEBUG, "NODEBUG,"},
1488     {CVf_LVALUE, "LVALUE,"},
1489     {CVf_METHOD, "METHOD,"},
1490     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1491     {CVf_CVGV_RC, "CVGV_RC,"},
1492     {CVf_ISXSUB, "ISXSUB,"}
1493 };
1494
1495 const struct flag_to_name hv_flags_names[] = {
1496     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1497     {SVphv_LAZYDEL, "LAZYDEL,"},
1498     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1499     {SVphv_REHASH, "REHASH,"},
1500     {SVphv_CLONEABLE, "CLONEABLE,"}
1501 };
1502
1503 const struct flag_to_name gp_flags_names[] = {
1504     {GVf_INTRO, "INTRO,"},
1505     {GVf_MULTI, "MULTI,"},
1506     {GVf_ASSUMECV, "ASSUMECV,"},
1507     {GVf_IN_PAD, "IN_PAD,"}
1508 };
1509
1510 const struct flag_to_name gp_flags_imported_names[] = {
1511     {GVf_IMPORTED_SV, " SV"},
1512     {GVf_IMPORTED_AV, " AV"},
1513     {GVf_IMPORTED_HV, " HV"},
1514     {GVf_IMPORTED_CV, " CV"},
1515 };
1516
1517 const struct flag_to_name regexp_flags_names[] = {
1518     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1519     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1520     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1521     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1522     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1523     {RXf_ANCH_BOL,        "ANCH_BOL,"},
1524     {RXf_ANCH_MBOL,       "ANCH_MBOL,"},
1525     {RXf_ANCH_SBOL,       "ANCH_SBOL,"},
1526     {RXf_ANCH_GPOS,       "ANCH_GPOS,"},
1527     {RXf_GPOS_SEEN,       "GPOS_SEEN,"},
1528     {RXf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1529     {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1530     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1531     {RXf_CANY_SEEN,       "CANY_SEEN,"},
1532     {RXf_NOSCAN,          "NOSCAN,"},
1533     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1534     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1535     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1536     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1537     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1538     {RXf_SPLIT,           "SPLIT,"},
1539     {RXf_COPY_DONE,       "COPY_DONE,"},
1540     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1541     {RXf_TAINTED,         "TAINTED,"},
1542     {RXf_START_ONLY,      "START_ONLY,"},
1543     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1544     {RXf_WHITE,           "WHITE,"},
1545     {RXf_NULL,            "NULL,"},
1546 };
1547
1548 void
1549 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1550 {
1551     dVAR;
1552     SV *d;
1553     const char *s;
1554     U32 flags;
1555     U32 type;
1556
1557     PERL_ARGS_ASSERT_DO_SV_DUMP;
1558
1559     if (!sv) {
1560         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1561         return;
1562     }
1563
1564     flags = SvFLAGS(sv);
1565     type = SvTYPE(sv);
1566
1567     /* process general SV flags */
1568
1569     d = Perl_newSVpvf(aTHX_
1570                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1571                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1572                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1573                    (int)(PL_dumpindent*level), "");
1574
1575     if (!((flags & SVpad_NAME) == SVpad_NAME
1576           && (type == SVt_PVMG || type == SVt_PVNV))) {
1577         if (flags & SVs_PADSTALE)       sv_catpv(d, "PADSTALE,");
1578     }
1579     if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1580         if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1581         if (flags & SVs_PADMY)  sv_catpv(d, "PADMY,");
1582     }
1583     append_flags(d, flags, first_sv_flags_names);
1584     if (flags & SVf_ROK)  {     
1585                                 sv_catpv(d, "ROK,");
1586         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1587     }
1588     append_flags(d, flags, second_sv_flags_names);
1589     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1590         if (SvPCS_IMPORTED(sv))
1591                                 sv_catpv(d, "PCS_IMPORTED,");
1592         else
1593                                 sv_catpv(d, "SCREAM,");
1594     }
1595
1596     /* process type-specific SV flags */
1597
1598     switch (type) {
1599     case SVt_PVCV:
1600     case SVt_PVFM:
1601         append_flags(d, CvFLAGS(sv), cv_flags_names);
1602         break;
1603     case SVt_PVHV:
1604         append_flags(d, flags, hv_flags_names);
1605         break;
1606     case SVt_PVGV:
1607     case SVt_PVLV:
1608         if (isGV_with_GP(sv)) {
1609             append_flags(d, GvFLAGS(sv), gp_flags_names);
1610         }
1611         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1612             sv_catpv(d, "IMPORT");
1613             if (GvIMPORTED(sv) == GVf_IMPORTED)
1614                 sv_catpv(d, "ALL,");
1615             else {
1616                 sv_catpv(d, "(");
1617                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1618                 sv_catpv(d, " ),");
1619             }
1620         }
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 (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1629         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1630         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1631         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1632         /* FALL THROUGH */
1633     case SVt_PVNV:
1634         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1635         goto evaled_or_uv;
1636     case SVt_PVAV:
1637         break;
1638     }
1639     /* SVphv_SHAREKEYS is also 0x20000000 */
1640     if ((type != SVt_PVHV) && SvUTF8(sv))
1641         sv_catpv(d, "UTF8");
1642
1643     if (*(SvEND(d) - 1) == ',') {
1644         SvCUR_set(d, SvCUR(d) - 1);
1645         SvPVX(d)[SvCUR(d)] = '\0';
1646     }
1647     sv_catpv(d, ")");
1648     s = SvPVX_const(d);
1649
1650     /* dump initial SV details */
1651
1652 #ifdef DEBUG_LEAKING_SCALARS
1653     Perl_dump_indent(aTHX_ level, file,
1654         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1655         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1656         sv->sv_debug_line,
1657         sv->sv_debug_inpad ? "for" : "by",
1658         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1659         PTR2UV(sv->sv_debug_parent),
1660         sv->sv_debug_serial
1661     );
1662 #endif
1663     Perl_dump_indent(aTHX_ level, file, "SV = ");
1664
1665     /* Dump SV type */
1666
1667     if (type < SVt_LAST) {
1668         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1669
1670         if (type ==  SVt_NULL) {
1671             SvREFCNT_dec(d);
1672             return;
1673         }
1674     } else {
1675         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1676         SvREFCNT_dec(d);
1677         return;
1678     }
1679
1680     /* Dump general SV fields */
1681
1682     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1683          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1684          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1685         || (type == SVt_IV && !SvROK(sv))) {
1686         if (SvIsUV(sv)
1687 #ifdef PERL_OLD_COPY_ON_WRITE
1688                        || SvIsCOW(sv)
1689 #endif
1690                                      )
1691             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1692         else
1693             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1694 #ifdef PERL_OLD_COPY_ON_WRITE
1695         if (SvIsCOW_shared_hash(sv))
1696             PerlIO_printf(file, "  (HASH)");
1697         else if (SvIsCOW_normal(sv))
1698             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1699 #endif
1700         PerlIO_putc(file, '\n');
1701     }
1702
1703     if ((type == SVt_PVNV || type == SVt_PVMG)
1704         && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1705         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1706                          (UV) COP_SEQ_RANGE_LOW(sv));
1707         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1708                          (UV) COP_SEQ_RANGE_HIGH(sv));
1709     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1710                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1711                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1712                || type == SVt_NV) {
1713         STORE_NUMERIC_LOCAL_SET_STANDARD();
1714         /* %Vg doesn't work? --jhi */
1715 #ifdef USE_LONG_DOUBLE
1716         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1717 #else
1718         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1719 #endif
1720         RESTORE_NUMERIC_LOCAL();
1721     }
1722
1723     if (SvROK(sv)) {
1724         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1725         if (nest < maxnest)
1726             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1727     }
1728
1729     if (type < SVt_PV) {
1730         SvREFCNT_dec(d);
1731         return;
1732     }
1733
1734     if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1735         if (SvPVX_const(sv)) {
1736             STRLEN delta;
1737             if (SvOOK(sv)) {
1738                 SvOOK_offset(sv, delta);
1739                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1740                                  (UV) delta);
1741             } else {
1742                 delta = 0;
1743             }
1744             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1745             if (SvOOK(sv)) {
1746                 PerlIO_printf(file, "( %s . ) ",
1747                               pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1748                                          pvlim));
1749             }
1750             PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1751             if (SvUTF8(sv)) /* the 6?  \x{....} */
1752                 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1753             PerlIO_printf(file, "\n");
1754             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1755             Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
1756         }
1757         else
1758             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1759     }
1760
1761     if (type >= SVt_PVMG) {
1762         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1763             HV * const ost = SvOURSTASH(sv);
1764             if (ost)
1765                 do_hv_dump(level, file, "  OURSTASH", ost);
1766         } else {
1767             if (SvMAGIC(sv))
1768                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1769         }
1770         if (SvSTASH(sv))
1771             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1772
1773         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1774             Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
1775             Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1776             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1777         }
1778     }
1779
1780     /* Dump type-specific SV fields */
1781
1782     switch (type) {
1783     case SVt_PVAV:
1784         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1785         if (AvARRAY(sv) != AvALLOC(sv)) {
1786             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1787             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1788         }
1789         else
1790             PerlIO_putc(file, '\n');
1791         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1792         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1793         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1794         sv_setpvs(d, "");
1795         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1796         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1797         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1798                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1799         if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1800             int count;
1801             for (count = 0; count <=  av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1802                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1803
1804                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1805                 if (elt)
1806                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1807             }
1808         }
1809         break;
1810     case SVt_PVHV:
1811         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1812         if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1813             /* Show distribution of HEs in the ARRAY */
1814             int freq[200];
1815 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1816             int i;
1817             int max = 0;
1818             U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1819             NV theoret, sum = 0;
1820
1821             PerlIO_printf(file, "  (");
1822             Zero(freq, FREQ_MAX + 1, int);
1823             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1824                 HE* h;
1825                 int count = 0;
1826                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1827                     count++;
1828                 if (count > FREQ_MAX)
1829                     count = FREQ_MAX;
1830                 freq[count]++;
1831                 if (max < count)
1832                     max = count;
1833             }
1834             for (i = 0; i <= max; i++) {
1835                 if (freq[i]) {
1836                     PerlIO_printf(file, "%d%s:%d", i,
1837                                   (i == FREQ_MAX) ? "+" : "",
1838                                   freq[i]);
1839                     if (i != max)
1840                         PerlIO_printf(file, ", ");
1841                 }
1842             }
1843             PerlIO_putc(file, ')');
1844             /* The "quality" of a hash is defined as the total number of
1845                comparisons needed to access every element once, relative
1846                to the expected number needed for a random hash.
1847
1848                The total number of comparisons is equal to the sum of
1849                the squares of the number of entries in each bucket.
1850                For a random hash of n keys into k buckets, the expected
1851                value is
1852                                 n + n(n-1)/2k
1853             */
1854
1855             for (i = max; i > 0; i--) { /* Precision: count down. */
1856                 sum += freq[i] * i * i;
1857             }
1858             while ((keys = keys >> 1))
1859                 pow2 = pow2 << 1;
1860             theoret = HvUSEDKEYS(sv);
1861             theoret += theoret * (theoret-1)/pow2;
1862             PerlIO_putc(file, '\n');
1863             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1864         }
1865         PerlIO_putc(file, '\n');
1866         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1867         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1868         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1869         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1870         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1871         {
1872             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1873             if (mg && mg->mg_obj) {
1874                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1875             }
1876         }
1877         {
1878             const char * const hvname = HvNAME_get(sv);
1879             if (hvname)
1880                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1881         }
1882         if (SvOOK(sv)) {
1883             AV * const backrefs
1884                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1885             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1886             if (HvAUX(sv)->xhv_name_count)
1887                 Perl_dump_indent(aTHX_
1888                  level, file, "  NAMECOUNT = %"IVdf"\n",
1889                  (IV)HvAUX(sv)->xhv_name_count
1890                 );
1891             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1892                 const I32 count = HvAUX(sv)->xhv_name_count;
1893                 if (count) {
1894                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1895                     /* The starting point is the first element if count is
1896                        positive and the second element if count is negative. */
1897                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1898                         + (count < 0 ? 1 : 0);
1899                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1900                         + (count < 0 ? -count : count);
1901                     while (hekp < endp) {
1902                         if (*hekp) {
1903                             sv_catpvs(names, ", \"");
1904                             sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1905                             sv_catpvs(names, "\"");
1906                         } else {
1907                             /* This should never happen. */
1908                             sv_catpvs(names, ", (null)");
1909                         }
1910                         ++hekp;
1911                     }
1912                     Perl_dump_indent(aTHX_
1913                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1914                     );
1915                 }
1916                 else
1917                     Perl_dump_indent(aTHX_
1918                      level, file, "  ENAME = \"%s\"\n", HvENAME_get(sv)
1919                     );
1920             }
1921             if (backrefs) {
1922                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1923                                  PTR2UV(backrefs));
1924                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1925                            dumpops, pvlim);
1926             }
1927             if (meta) {
1928                 /* FIXME - mro_algs kflags can signal a UTF-8 name.  */
1929                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1930                                  (int)meta->mro_which->length,
1931                                  meta->mro_which->name,
1932                                  PTR2UV(meta->mro_which));
1933                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1934                                  (UV)meta->cache_gen);
1935                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1936                                  (UV)meta->pkg_gen);
1937                 if (meta->mro_linear_all) {
1938                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1939                                  PTR2UV(meta->mro_linear_all));
1940                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1941                            dumpops, pvlim);
1942                 }
1943                 if (meta->mro_linear_current) {
1944                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1945                                  PTR2UV(meta->mro_linear_current));
1946                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1947                            dumpops, pvlim);
1948                 }
1949                 if (meta->mro_nextmethod) {
1950                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1951                                  PTR2UV(meta->mro_nextmethod));
1952                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1953                            dumpops, pvlim);
1954                 }
1955                 if (meta->isa) {
1956                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1957                                  PTR2UV(meta->isa));
1958                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1959                            dumpops, pvlim);
1960                 }
1961             }
1962         }
1963         if (nest < maxnest) {
1964             if (HvEITER_get(sv)) /* preserve iterator */
1965                 Perl_dump_indent(aTHX_ level, file,
1966                     "  (*** Active iterator; skipping element dump ***)\n");
1967             else {
1968                 HE *he;
1969                 HV * const hv = MUTABLE_HV(sv);
1970                 int count = maxnest - nest;
1971
1972                 hv_iterinit(hv);
1973                 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1974                        && count--) {
1975                     STRLEN len;
1976                     const U32 hash = HeHASH(he);
1977                     SV * const keysv = hv_iterkeysv(he);
1978                     const char * const keypv = SvPV_const(keysv, len);
1979                     SV * const elt = hv_iterval(hv, he);
1980
1981                     Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1982                     if (SvUTF8(keysv))
1983                         PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1984                     if (HeKREHASH(he))
1985                         PerlIO_printf(file, "[REHASH] ");
1986                     PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1987                     do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1988                 }
1989                 hv_iterinit(hv);                /* Return to status quo */
1990             }
1991         }
1992         break;
1993
1994     case SVt_PVCV:
1995         if (SvPOK(sv)) {
1996             STRLEN len;
1997             const char *const proto =  SvPV_const(sv, len);
1998             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1999                              (int) len, proto);
2000         }
2001         /* FALL THROUGH */
2002     case SVt_PVFM:
2003         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
2004         if (!CvISXSUB(sv)) {
2005             if (CvSTART(sv)) {
2006                 Perl_dump_indent(aTHX_ level, file,
2007                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
2008                                  PTR2UV(CvSTART(sv)),
2009                                  (IV)sequence_num(CvSTART(sv)));
2010             }
2011             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
2012                              PTR2UV(CvROOT(sv)));
2013             if (CvROOT(sv) && dumpops) {
2014                 do_op_dump(level+1, file, CvROOT(sv));
2015             }
2016         } else {
2017             SV * const constant = cv_const_sv((const CV *)sv);
2018
2019             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2020
2021             if (constant) {
2022                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
2023                                  " (CONST SV)\n",
2024                                  PTR2UV(CvXSUBANY(sv).any_ptr));
2025                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2026                            pvlim);
2027             } else {
2028                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
2029                                  (IV)CvXSUBANY(sv).any_i32);
2030             }
2031         }
2032         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
2033         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
2034         if (type == SVt_PVCV)
2035             Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2036         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2037         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2038         if (type == SVt_PVFM)
2039             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
2040         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2041         if (nest < maxnest) {
2042             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2043         }
2044         {
2045             const CV * const outside = CvOUTSIDE(sv);
2046             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
2047                         PTR2UV(outside),
2048                         (!outside ? "null"
2049                          : CvANON(outside) ? "ANON"
2050                          : (outside == PL_main_cv) ? "MAIN"
2051                          : CvUNIQUE(outside) ? "UNIQUE"
2052                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2053         }
2054         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2055             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2056         break;
2057
2058     case SVt_PVGV:
2059     case SVt_PVLV:
2060         if (type == SVt_PVLV) {
2061             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2062             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2063             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2064             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2065             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2066                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2067                     dumpops, pvlim);
2068         }
2069         if (!isGV_with_GP(sv))
2070             break;
2071         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
2072         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2073         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2074         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2075         if (!GvGP(sv))
2076             break;
2077         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2078         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2079         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2080         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2081         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2082         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2083         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2084         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2085         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2086         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2087         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2088         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2089         break;
2090     case SVt_PVIO:
2091         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2092         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2093         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2094         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2095         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2096         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2097         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2098         if (IoTOP_NAME(sv))
2099             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2100         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2101             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2102         else {
2103             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2104                              PTR2UV(IoTOP_GV(sv)));
2105             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2106                         maxnest, dumpops, pvlim);
2107         }
2108         /* Source filters hide things that are not GVs in these three, so let's
2109            be careful out there.  */
2110         if (IoFMT_NAME(sv))
2111             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2112         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2113             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2114         else {
2115             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2116                              PTR2UV(IoFMT_GV(sv)));
2117             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2118                         maxnest, dumpops, pvlim);
2119         }
2120         if (IoBOTTOM_NAME(sv))
2121             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2122         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2123             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2124         else {
2125             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2126                              PTR2UV(IoBOTTOM_GV(sv)));
2127             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2128                         maxnest, dumpops, pvlim);
2129         }
2130         if (isPRINT(IoTYPE(sv)))
2131             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2132         else
2133             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2134         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2135         break;
2136     case SVt_REGEXP:
2137         {
2138             struct regexp * const r = (struct regexp *)SvANY(sv);
2139             flags = RX_EXTFLAGS((REGEXP*)sv);
2140             sv_setpv(d,"");
2141             append_flags(d, flags, regexp_flags_names);
2142             if (*(SvEND(d) - 1) == ',') {
2143                 SvCUR_set(d, SvCUR(d) - 1);
2144                 SvPVX(d)[SvCUR(d)] = '\0';
2145             }
2146             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2147                                 (UV)flags, SvPVX_const(d));
2148             Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2149                                 (UV)(r->intflags));
2150             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2151                                 (UV)(r->nparens));
2152             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2153                                 (UV)(r->lastparen));
2154             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2155                                 (UV)(r->lastcloseparen));
2156             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2157                                 (IV)(r->minlen));
2158             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2159                                 (IV)(r->minlenret));
2160             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2161                                 (UV)(r->gofs));
2162             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2163                                 (UV)(r->pre_prefix));
2164             Perl_dump_indent(aTHX_ level, file, "  SEEN_EVALS = %"UVuf"\n",
2165                                 (UV)(r->seen_evals));
2166             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2167                                 (IV)(r->sublen));
2168             if (r->subbeg)
2169                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2170                             PTR2UV(r->subbeg),
2171                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2172             else
2173                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2174             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf"\n",
2175                                 PTR2UV(r->engine));
2176             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2177                                 PTR2UV(r->mother_re));
2178             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2179                                 PTR2UV(r->paren_names));
2180             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2181                                 PTR2UV(r->substrs));
2182             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2183                                 PTR2UV(r->pprivate));
2184             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2185                                 PTR2UV(r->offs));
2186 #ifdef PERL_OLD_COPY_ON_WRITE
2187             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2188                                 PTR2UV(r->saved_copy));
2189 #endif
2190         }
2191         break;
2192     }
2193     SvREFCNT_dec(d);
2194 }
2195
2196 void
2197 Perl_sv_dump(pTHX_ SV *sv)
2198 {
2199     dVAR;
2200
2201     PERL_ARGS_ASSERT_SV_DUMP;
2202
2203     if (SvROK(sv))
2204         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2205     else
2206         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2207 }
2208
2209 int
2210 Perl_runops_debug(pTHX)
2211 {
2212     dVAR;
2213     if (!PL_op) {
2214         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2215         return 0;
2216     }
2217
2218     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2219     do {
2220         if (PL_debug) {
2221             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2222                 PerlIO_printf(Perl_debug_log,
2223                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2224                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2225                               PTR2UV(*PL_watchaddr));
2226             if (DEBUG_s_TEST_) {
2227                 if (DEBUG_v_TEST_) {
2228                     PerlIO_printf(Perl_debug_log, "\n");
2229                     deb_stack_all();
2230                 }
2231                 else
2232                     debstack();
2233             }
2234
2235
2236             if (DEBUG_t_TEST_) debop(PL_op);
2237             if (DEBUG_P_TEST_) debprof(PL_op);
2238         }
2239     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2240     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2241
2242     TAINT_NOT;
2243     return 0;
2244 }
2245
2246 I32
2247 Perl_debop(pTHX_ const OP *o)
2248 {
2249     dVAR;
2250
2251     PERL_ARGS_ASSERT_DEBOP;
2252
2253     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2254         return 0;
2255
2256     Perl_deb(aTHX_ "%s", OP_NAME(o));
2257     switch (o->op_type) {
2258     case OP_CONST:
2259     case OP_HINTSEVAL:
2260         /* With ITHREADS, consts are stored in the pad, and the right pad
2261          * may not be active here, so check.
2262          * Looks like only during compiling the pads are illegal.
2263          */
2264 #ifdef USE_ITHREADS
2265         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2266 #endif
2267             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2268         break;
2269     case OP_GVSV:
2270     case OP_GV:
2271         if (cGVOPo_gv) {
2272             SV * const sv = newSV(0);
2273 #ifdef PERL_MAD
2274             /* FIXME - is this making unwarranted assumptions about the
2275                UTF-8 cleanliness of the dump file handle?  */
2276             SvUTF8_on(sv);
2277 #endif
2278             gv_fullname3(sv, cGVOPo_gv, NULL);
2279             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2280             SvREFCNT_dec(sv);
2281         }
2282         else
2283             PerlIO_printf(Perl_debug_log, "(NULL)");
2284         break;
2285     case OP_PADSV:
2286     case OP_PADAV:
2287     case OP_PADHV:
2288         {
2289         /* print the lexical's name */
2290         CV * const cv = deb_curcv(cxstack_ix);
2291         SV *sv;
2292         if (cv) {
2293             AV * const padlist = CvPADLIST(cv);
2294             AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2295             sv = *av_fetch(comppad, o->op_targ, FALSE);
2296         } else
2297             sv = NULL;
2298         if (sv)
2299             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2300         else
2301             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2302         }
2303         break;
2304     default:
2305         break;
2306     }
2307     PerlIO_printf(Perl_debug_log, "\n");
2308     return 0;
2309 }
2310
2311 STATIC CV*
2312 S_deb_curcv(pTHX_ const I32 ix)
2313 {
2314     dVAR;
2315     const PERL_CONTEXT * const cx = &cxstack[ix];
2316     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2317         return cx->blk_sub.cv;
2318     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2319         return PL_compcv;
2320     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2321         return PL_main_cv;
2322     else if (ix <= 0)
2323         return NULL;
2324     else
2325         return deb_curcv(ix - 1);
2326 }
2327
2328 void
2329 Perl_watch(pTHX_ char **addr)
2330 {
2331     dVAR;
2332
2333     PERL_ARGS_ASSERT_WATCH;
2334
2335     PL_watchaddr = addr;
2336     PL_watchok = *addr;
2337     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2338         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2339 }
2340
2341 STATIC void
2342 S_debprof(pTHX_ const OP *o)
2343 {
2344     dVAR;
2345
2346     PERL_ARGS_ASSERT_DEBPROF;
2347
2348     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2349         return;
2350     if (!PL_profiledata)
2351         Newxz(PL_profiledata, MAXO, U32);
2352     ++PL_profiledata[o->op_type];
2353 }
2354
2355 void
2356 Perl_debprofdump(pTHX)
2357 {
2358     dVAR;
2359     unsigned i;
2360     if (!PL_profiledata)
2361         return;
2362     for (i = 0; i < MAXO; i++) {
2363         if (PL_profiledata[i])
2364             PerlIO_printf(Perl_debug_log,
2365                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2366                                        PL_op_name[i]);
2367     }
2368 }
2369
2370 #ifdef PERL_MAD
2371 /*
2372  *    XML variants of most of the above routines
2373  */
2374
2375 STATIC void
2376 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2377 {
2378     va_list args;
2379
2380     PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2381
2382     PerlIO_printf(file, "\n    ");
2383     va_start(args, pat);
2384     xmldump_vindent(level, file, pat, &args);
2385     va_end(args);
2386 }
2387
2388
2389 void
2390 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2391 {
2392     va_list args;
2393     PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2394     va_start(args, pat);
2395     xmldump_vindent(level, file, pat, &args);
2396     va_end(args);
2397 }
2398
2399 void
2400 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2401 {
2402     PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2403
2404     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2405     PerlIO_vprintf(file, pat, *args);
2406 }
2407
2408 void
2409 Perl_xmldump_all(pTHX)
2410 {
2411     xmldump_all_perl(FALSE);
2412 }
2413
2414 void
2415 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2416 {
2417     PerlIO_setlinebuf(PL_xmlfp);
2418     if (PL_main_root)
2419         op_xmldump(PL_main_root);
2420     /* someday we might call this, when it outputs XML: */
2421     /* xmldump_packsubs_perl(PL_defstash, justperl); */
2422     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2423         PerlIO_close(PL_xmlfp);
2424     PL_xmlfp = 0;
2425 }
2426
2427 void
2428 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2429 {
2430     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2431     xmldump_packsubs_perl(stash, FALSE);
2432 }
2433
2434 void
2435 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2436 {
2437     I32 i;
2438     HE  *entry;
2439
2440     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2441
2442     if (!HvARRAY(stash))
2443         return;
2444     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2445         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2446             GV *gv = MUTABLE_GV(HeVAL(entry));
2447             HV *hv;
2448             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2449                 continue;
2450             if (GvCVu(gv))
2451                 xmldump_sub_perl(gv, justperl);
2452             if (GvFORM(gv))
2453                 xmldump_form(gv);
2454             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2455                 && (hv = GvHV(gv)) && hv != PL_defstash)
2456                 xmldump_packsubs_perl(hv, justperl);    /* nested package */
2457         }
2458     }
2459 }
2460
2461 void
2462 Perl_xmldump_sub(pTHX_ const GV *gv)
2463 {
2464     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2465     xmldump_sub_perl(gv, FALSE);
2466 }
2467
2468 void
2469 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2470 {
2471     SV * sv;
2472
2473     PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2474
2475     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2476         return;
2477
2478     sv = sv_newmortal();
2479     gv_fullname3(sv, gv, NULL);
2480     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2481     if (CvXSUB(GvCV(gv)))
2482         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2483             PTR2UV(CvXSUB(GvCV(gv))),
2484             (int)CvXSUBANY(GvCV(gv)).any_i32);
2485     else if (CvROOT(GvCV(gv)))
2486         op_xmldump(CvROOT(GvCV(gv)));
2487     else
2488         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2489 }
2490
2491 void
2492 Perl_xmldump_form(pTHX_ const GV *gv)
2493 {
2494     SV * const sv = sv_newmortal();
2495
2496     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2497
2498     gv_fullname3(sv, gv, NULL);
2499     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2500     if (CvROOT(GvFORM(gv)))
2501         op_xmldump(CvROOT(GvFORM(gv)));
2502     else
2503         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2504 }
2505
2506 void
2507 Perl_xmldump_eval(pTHX)
2508 {
2509     op_xmldump(PL_eval_root);
2510 }
2511
2512 char *
2513 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2514 {
2515     PERL_ARGS_ASSERT_SV_CATXMLSV;
2516     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2517 }
2518
2519 char *
2520 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2521 {
2522     PERL_ARGS_ASSERT_SV_CATXMLPV;
2523     return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2524 }
2525
2526 char *
2527 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2528 {
2529     unsigned int c;
2530     const char * const e = pv + len;
2531     const char * const start = pv;
2532     STRLEN dsvcur;
2533     STRLEN cl;
2534
2535     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2536
2537     sv_catpvs(dsv,"");
2538     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2539
2540   retry:
2541     while (pv < e) {
2542         if (utf8) {
2543             c = utf8_to_uvchr((U8*)pv, &cl);
2544             if (cl == 0) {
2545                 SvCUR(dsv) = dsvcur;
2546                 pv = start;
2547                 utf8 = 0;
2548                 goto retry;
2549             }
2550         }
2551         else
2552             c = (*pv & 255);
2553
2554         switch (c) {
2555         case 0x00:
2556         case 0x01:
2557         case 0x02:
2558         case 0x03:
2559         case 0x04:
2560         case 0x05:
2561         case 0x06:
2562         case 0x07:
2563         case 0x08:
2564         case 0x0b:
2565         case 0x0c:
2566         case 0x0e:
2567         case 0x0f:
2568         case 0x10:
2569         case 0x11:
2570         case 0x12:
2571         case 0x13:
2572         case 0x14:
2573         case 0x15:
2574         case 0x16:
2575         case 0x17:
2576         case 0x18:
2577         case 0x19:
2578         case 0x1a:
2579         case 0x1b:
2580         case 0x1c:
2581         case 0x1d:
2582         case 0x1e:
2583         case 0x1f:
2584         case 0x7f:
2585         case 0x80:
2586         case 0x81:
2587         case 0x82:
2588         case 0x83:
2589         case 0x84:
2590         case 0x86:
2591         case 0x87:
2592         case 0x88:
2593         case 0x89:
2594         case 0x90:
2595         case 0x91:
2596         case 0x92:
2597         case 0x93:
2598         case 0x94:
2599         case 0x95:
2600         case 0x96:
2601         case 0x97:
2602         case 0x98:
2603         case 0x99:
2604         case 0x9a:
2605         case 0x9b:
2606         case 0x9c:
2607         case 0x9d:
2608         case 0x9e:
2609         case 0x9f:
2610             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2611             break;
2612         case '<':
2613             sv_catpvs(dsv, "&lt;");
2614             break;
2615         case '>':
2616             sv_catpvs(dsv, "&gt;");
2617             break;
2618         case '&':
2619             sv_catpvs(dsv, "&amp;");
2620             break;
2621         case '"':
2622             sv_catpvs(dsv, "&#34;");
2623             break;
2624         default:
2625             if (c < 0xD800) {
2626                 if (c < 32 || c > 127) {
2627                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2628                 }
2629                 else {
2630                     const char string = (char) c;
2631                     sv_catpvn(dsv, &string, 1);
2632                 }
2633                 break;
2634             }
2635             if ((c >= 0xD800 && c <= 0xDB7F) ||
2636                 (c >= 0xDC00 && c <= 0xDFFF) ||
2637                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2638                  c > 0x10ffff)
2639                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2640             else
2641                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2642         }
2643
2644         if (utf8)
2645             pv += UTF8SKIP(pv);
2646         else
2647             pv++;
2648     }
2649
2650     return SvPVX(dsv);
2651 }
2652
2653 char *
2654 Perl_sv_xmlpeek(pTHX_ SV *sv)
2655 {
2656     SV * const t = sv_newmortal();
2657     STRLEN n_a;
2658     int unref = 0;
2659
2660     PERL_ARGS_ASSERT_SV_XMLPEEK;
2661
2662     sv_utf8_upgrade(t);
2663     sv_setpvs(t, "");
2664     /* retry: */
2665     if (!sv) {
2666         sv_catpv(t, "VOID=\"\"");
2667         goto finish;
2668     }
2669     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2670         sv_catpv(t, "WILD=\"\"");
2671         goto finish;
2672     }
2673     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2674         if (sv == &PL_sv_undef) {
2675             sv_catpv(t, "SV_UNDEF=\"1\"");
2676             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2677                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2678                 SvREADONLY(sv))
2679                 goto finish;
2680         }
2681         else if (sv == &PL_sv_no) {
2682             sv_catpv(t, "SV_NO=\"1\"");
2683             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2684                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2685                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2686                                   SVp_POK|SVp_NOK)) &&
2687                 SvCUR(sv) == 0 &&
2688                 SvNVX(sv) == 0.0)
2689                 goto finish;
2690         }
2691         else if (sv == &PL_sv_yes) {
2692             sv_catpv(t, "SV_YES=\"1\"");
2693             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2694                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2695                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2696                                   SVp_POK|SVp_NOK)) &&
2697                 SvCUR(sv) == 1 &&
2698                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2699                 SvNVX(sv) == 1.0)
2700                 goto finish;
2701         }
2702         else {
2703             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2704             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2705                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2706                 SvREADONLY(sv))
2707                 goto finish;
2708         }
2709         sv_catpv(t, " XXX=\"\" ");
2710     }
2711     else if (SvREFCNT(sv) == 0) {
2712         sv_catpv(t, " refcnt=\"0\"");
2713         unref++;
2714     }
2715     else if (DEBUG_R_TEST_) {
2716         int is_tmp = 0;
2717         I32 ix;
2718         /* is this SV on the tmps stack? */
2719         for (ix=PL_tmps_ix; ix>=0; ix--) {
2720             if (PL_tmps_stack[ix] == sv) {
2721                 is_tmp = 1;
2722                 break;
2723             }
2724         }
2725         if (SvREFCNT(sv) > 1)
2726             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2727                     is_tmp ? "T" : "");
2728         else if (is_tmp)
2729             sv_catpv(t, " DRT=\"<T>\"");
2730     }
2731
2732     if (SvROK(sv)) {
2733         sv_catpv(t, " ROK=\"\"");
2734     }
2735     switch (SvTYPE(sv)) {
2736     default:
2737         sv_catpv(t, " FREED=\"1\"");
2738         goto finish;
2739
2740     case SVt_NULL:
2741         sv_catpv(t, " UNDEF=\"1\"");
2742         goto finish;
2743     case SVt_IV:
2744         sv_catpv(t, " IV=\"");
2745         break;
2746     case SVt_NV:
2747         sv_catpv(t, " NV=\"");
2748         break;
2749     case SVt_PV:
2750         sv_catpv(t, " PV=\"");
2751         break;
2752     case SVt_PVIV:
2753         sv_catpv(t, " PVIV=\"");
2754         break;
2755     case SVt_PVNV:
2756         sv_catpv(t, " PVNV=\"");
2757         break;
2758     case SVt_PVMG:
2759         sv_catpv(t, " PVMG=\"");
2760         break;
2761     case SVt_PVLV:
2762         sv_catpv(t, " PVLV=\"");
2763         break;
2764     case SVt_PVAV:
2765         sv_catpv(t, " AV=\"");
2766         break;
2767     case SVt_PVHV:
2768         sv_catpv(t, " HV=\"");
2769         break;
2770     case SVt_PVCV:
2771         if (CvGV(sv))
2772             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2773         else
2774             sv_catpv(t, " CV=\"()\"");
2775         goto finish;
2776     case SVt_PVGV:
2777         sv_catpv(t, " GV=\"");
2778         break;
2779     case SVt_BIND:
2780         sv_catpv(t, " BIND=\"");
2781         break;
2782     case SVt_REGEXP:
2783         sv_catpv(t, " REGEXP=\"");
2784         break;
2785     case SVt_PVFM:
2786         sv_catpv(t, " FM=\"");
2787         break;
2788     case SVt_PVIO:
2789         sv_catpv(t, " IO=\"");
2790         break;
2791     }
2792
2793     if (SvPOKp(sv)) {
2794         if (SvPVX(sv)) {
2795             sv_catxmlsv(t, sv);
2796         }
2797     }
2798     else if (SvNOKp(sv)) {
2799         STORE_NUMERIC_LOCAL_SET_STANDARD();
2800         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2801         RESTORE_NUMERIC_LOCAL();
2802     }
2803     else if (SvIOKp(sv)) {
2804         if (SvIsUV(sv))
2805             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2806         else
2807             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2808     }
2809     else
2810         sv_catpv(t, "");
2811     sv_catpv(t, "\"");
2812
2813   finish:
2814     while (unref--)
2815         sv_catpv(t, ")");
2816     return SvPV(t, n_a);
2817 }
2818
2819 void
2820 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2821 {
2822     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2823
2824     if (!pm) {
2825         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2826         return;
2827     }
2828     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2829     level++;
2830     if (PM_GETRE(pm)) {
2831         REGEXP *const r = PM_GETRE(pm);
2832         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2833         sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2834         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2835              SvPVX(tmpsv));
2836         SvREFCNT_dec(tmpsv);
2837         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2838              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2839     }
2840     else
2841         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2842     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2843         SV * const tmpsv = pm_description(pm);
2844         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2845         SvREFCNT_dec(tmpsv);
2846     }
2847
2848     level--;
2849     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2850         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2851         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2852         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2853         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2854         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2855     }
2856     else
2857         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2858 }
2859
2860 void
2861 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2862 {
2863     do_pmop_xmldump(0, PL_xmlfp, pm);
2864 }
2865
2866 void
2867 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2868 {
2869     UV      seq;
2870     int     contents = 0;
2871
2872     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2873
2874     if (!o)
2875         return;
2876     sequence(o);
2877     seq = sequence_num(o);
2878     Perl_xmldump_indent(aTHX_ level, file,
2879         "<op_%s seq=\"%"UVuf" -> ",
2880              OP_NAME(o),
2881                       seq);
2882     level++;
2883     if (o->op_next)
2884         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2885                       sequence_num(o->op_next));
2886     else
2887         PerlIO_printf(file, "DONE\"");
2888
2889     if (o->op_targ) {
2890         if (o->op_type == OP_NULL)
2891         {
2892             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2893             if (o->op_targ == OP_NEXTSTATE)
2894             {
2895                 if (CopLINE(cCOPo))
2896                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2897                                      (UV)CopLINE(cCOPo));
2898                 if (CopSTASHPV(cCOPo))
2899                     PerlIO_printf(file, " package=\"%s\"",
2900                                      CopSTASHPV(cCOPo));
2901                 if (CopLABEL(cCOPo))
2902                     PerlIO_printf(file, " label=\"%s\"",
2903                                      CopLABEL(cCOPo));
2904             }
2905         }
2906         else
2907             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2908     }
2909 #ifdef DUMPADDR
2910     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2911 #endif
2912     if (o->op_flags) {
2913         SV * const tmpsv = newSVpvs("");
2914         switch (o->op_flags & OPf_WANT) {
2915         case OPf_WANT_VOID:
2916             sv_catpv(tmpsv, ",VOID");
2917             break;
2918         case OPf_WANT_SCALAR:
2919             sv_catpv(tmpsv, ",SCALAR");
2920             break;
2921         case OPf_WANT_LIST:
2922             sv_catpv(tmpsv, ",LIST");
2923             break;
2924         default:
2925             sv_catpv(tmpsv, ",UNKNOWN");
2926             break;
2927         }
2928         if (o->op_flags & OPf_KIDS)
2929             sv_catpv(tmpsv, ",KIDS");
2930         if (o->op_flags & OPf_PARENS)
2931             sv_catpv(tmpsv, ",PARENS");
2932         if (o->op_flags & OPf_STACKED)
2933             sv_catpv(tmpsv, ",STACKED");
2934         if (o->op_flags & OPf_REF)
2935             sv_catpv(tmpsv, ",REF");
2936         if (o->op_flags & OPf_MOD)
2937             sv_catpv(tmpsv, ",MOD");
2938         if (o->op_flags & OPf_SPECIAL)
2939             sv_catpv(tmpsv, ",SPECIAL");
2940         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2941         SvREFCNT_dec(tmpsv);
2942     }
2943     if (o->op_private) {
2944         SV * const tmpsv = newSVpvs("");
2945         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2946             if (o->op_private & OPpTARGET_MY)
2947                 sv_catpv(tmpsv, ",TARGET_MY");
2948         }
2949         else if (o->op_type == OP_LEAVESUB ||
2950                  o->op_type == OP_LEAVE ||
2951                  o->op_type == OP_LEAVESUBLV ||
2952                  o->op_type == OP_LEAVEWRITE) {
2953             if (o->op_private & OPpREFCOUNTED)
2954                 sv_catpv(tmpsv, ",REFCOUNTED");
2955         }
2956         else if (o->op_type == OP_AASSIGN) {
2957             if (o->op_private & OPpASSIGN_COMMON)
2958                 sv_catpv(tmpsv, ",COMMON");
2959         }
2960         else if (o->op_type == OP_SASSIGN) {
2961             if (o->op_private & OPpASSIGN_BACKWARDS)
2962                 sv_catpv(tmpsv, ",BACKWARDS");
2963         }
2964         else if (o->op_type == OP_TRANS) {
2965             if (o->op_private & OPpTRANS_SQUASH)
2966                 sv_catpv(tmpsv, ",SQUASH");
2967             if (o->op_private & OPpTRANS_DELETE)
2968                 sv_catpv(tmpsv, ",DELETE");
2969             if (o->op_private & OPpTRANS_COMPLEMENT)
2970                 sv_catpv(tmpsv, ",COMPLEMENT");
2971             if (o->op_private & OPpTRANS_IDENTICAL)
2972                 sv_catpv(tmpsv, ",IDENTICAL");
2973             if (o->op_private & OPpTRANS_GROWS)
2974                 sv_catpv(tmpsv, ",GROWS");
2975         }
2976         else if (o->op_type == OP_REPEAT) {
2977             if (o->op_private & OPpREPEAT_DOLIST)
2978                 sv_catpv(tmpsv, ",DOLIST");
2979         }
2980         else if (o->op_type == OP_ENTERSUB ||
2981                  o->op_type == OP_RV2SV ||
2982                  o->op_type == OP_GVSV ||
2983                  o->op_type == OP_RV2AV ||
2984                  o->op_type == OP_RV2HV ||
2985                  o->op_type == OP_RV2GV ||
2986                  o->op_type == OP_AELEM ||
2987                  o->op_type == OP_HELEM )
2988         {
2989             if (o->op_type == OP_ENTERSUB) {
2990                 if (o->op_private & OPpENTERSUB_AMPER)
2991                     sv_catpv(tmpsv, ",AMPER");
2992                 if (o->op_private & OPpENTERSUB_DB)
2993                     sv_catpv(tmpsv, ",DB");
2994                 if (o->op_private & OPpENTERSUB_HASTARG)
2995                     sv_catpv(tmpsv, ",HASTARG");
2996                 if (o->op_private & OPpENTERSUB_NOPAREN)
2997                     sv_catpv(tmpsv, ",NOPAREN");
2998                 if (o->op_private & OPpENTERSUB_INARGS)
2999                     sv_catpv(tmpsv, ",INARGS");
3000                 if (o->op_private & OPpENTERSUB_NOMOD)
3001                     sv_catpv(tmpsv, ",NOMOD");
3002             }
3003             else {
3004                 switch (o->op_private & OPpDEREF) {
3005             case OPpDEREF_SV:
3006                 sv_catpv(tmpsv, ",SV");
3007                 break;
3008             case OPpDEREF_AV:
3009                 sv_catpv(tmpsv, ",AV");
3010                 break;
3011             case OPpDEREF_HV:
3012                 sv_catpv(tmpsv, ",HV");
3013                 break;
3014             }
3015                 if (o->op_private & OPpMAYBE_LVSUB)
3016                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
3017             }
3018             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
3019                 if (o->op_private & OPpLVAL_DEFER)
3020                     sv_catpv(tmpsv, ",LVAL_DEFER");
3021             }
3022             else {
3023                 if (o->op_private & HINT_STRICT_REFS)
3024                     sv_catpv(tmpsv, ",STRICT_REFS");
3025                 if (o->op_private & OPpOUR_INTRO)
3026                     sv_catpv(tmpsv, ",OUR_INTRO");
3027             }
3028         }
3029         else if (o->op_type == OP_CONST) {
3030             if (o->op_private & OPpCONST_BARE)
3031                 sv_catpv(tmpsv, ",BARE");
3032             if (o->op_private & OPpCONST_STRICT)
3033                 sv_catpv(tmpsv, ",STRICT");
3034             if (o->op_private & OPpCONST_ARYBASE)
3035                 sv_catpv(tmpsv, ",ARYBASE");
3036             if (o->op_private & OPpCONST_WARNING)
3037                 sv_catpv(tmpsv, ",WARNING");
3038             if (o->op_private & OPpCONST_ENTERED)
3039                 sv_catpv(tmpsv, ",ENTERED");
3040         }
3041         else if (o->op_type == OP_FLIP) {
3042             if (o->op_private & OPpFLIP_LINENUM)
3043                 sv_catpv(tmpsv, ",LINENUM");
3044         }
3045         else if (o->op_type == OP_FLOP) {
3046             if (o->op_private & OPpFLIP_LINENUM)
3047                 sv_catpv(tmpsv, ",LINENUM");
3048         }
3049         else if (o->op_type == OP_RV2CV) {
3050             if (o->op_private & OPpLVAL_INTRO)
3051                 sv_catpv(tmpsv, ",INTRO");
3052         }
3053         else if (o->op_type == OP_GV) {
3054             if (o->op_private & OPpEARLY_CV)
3055                 sv_catpv(tmpsv, ",EARLY_CV");
3056         }
3057         else if (o->op_type == OP_LIST) {
3058             if (o->op_private & OPpLIST_GUESSED)
3059                 sv_catpv(tmpsv, ",GUESSED");
3060         }
3061         else if (o->op_type == OP_DELETE) {
3062             if (o->op_private & OPpSLICE)
3063                 sv_catpv(tmpsv, ",SLICE");
3064         }
3065         else if (o->op_type == OP_EXISTS) {
3066             if (o->op_private & OPpEXISTS_SUB)
3067                 sv_catpv(tmpsv, ",EXISTS_SUB");
3068         }
3069         else if (o->op_type == OP_SORT) {
3070             if (o->op_private & OPpSORT_NUMERIC)
3071                 sv_catpv(tmpsv, ",NUMERIC");
3072             if (o->op_private & OPpSORT_INTEGER)
3073                 sv_catpv(tmpsv, ",INTEGER");
3074             if (o->op_private & OPpSORT_REVERSE)
3075                 sv_catpv(tmpsv, ",REVERSE");
3076         }
3077         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
3078             if (o->op_private & OPpOPEN_IN_RAW)
3079                 sv_catpv(tmpsv, ",IN_RAW");
3080             if (o->op_private & OPpOPEN_IN_CRLF)
3081                 sv_catpv(tmpsv, ",IN_CRLF");
3082             if (o->op_private & OPpOPEN_OUT_RAW)
3083                 sv_catpv(tmpsv, ",OUT_RAW");
3084             if (o->op_private & OPpOPEN_OUT_CRLF)
3085                 sv_catpv(tmpsv, ",OUT_CRLF");
3086         }
3087         else if (o->op_type == OP_EXIT) {
3088             if (o->op_private & OPpEXIT_VMSISH)
3089                 sv_catpv(tmpsv, ",EXIT_VMSISH");
3090             if (o->op_private & OPpHUSH_VMSISH)
3091                 sv_catpv(tmpsv, ",HUSH_VMSISH");
3092         }
3093         else if (o->op_type == OP_DIE) {
3094             if (o->op_private & OPpHUSH_VMSISH)
3095                 sv_catpv(tmpsv, ",HUSH_VMSISH");
3096         }
3097         else if (PL_check[o->op_type] != Perl_ck_ftst) {
3098             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
3099                 sv_catpv(tmpsv, ",FT_ACCESS");
3100             if (o->op_private & OPpFT_STACKED)
3101                 sv_catpv(tmpsv, ",FT_STACKED");
3102         }
3103         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
3104             sv_catpv(tmpsv, ",INTRO");
3105         if (SvCUR(tmpsv))
3106             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
3107         SvREFCNT_dec(tmpsv);
3108     }
3109
3110     switch (o->op_type) {
3111     case OP_AELEMFAST:
3112         if (o->op_flags & OPf_SPECIAL) {
3113             break;
3114         }
3115     case OP_GVSV:
3116     case OP_GV:
3117 #ifdef USE_ITHREADS
3118         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3119 #else
3120         if (cSVOPo->op_sv) {
3121             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3122             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3123             char *s;
3124             STRLEN len;
3125             ENTER;
3126             SAVEFREESV(tmpsv1);
3127             SAVEFREESV(tmpsv2);
3128             gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3129             s = SvPV(tmpsv1,len);
3130             sv_catxmlpvn(tmpsv2, s, len, 1);
3131             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3132             LEAVE;
3133         }
3134         else
3135             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3136 #endif
3137         break;
3138     case OP_CONST:
3139     case OP_HINTSEVAL:
3140     case OP_METHOD_NAMED:
3141 #ifndef USE_ITHREADS
3142         /* with ITHREADS, consts are stored in the pad, and the right pad
3143          * may not be active here, so skip */
3144         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3145 #endif
3146         break;
3147     case OP_ANONCODE:
3148         if (!contents) {
3149             contents = 1;
3150             PerlIO_printf(file, ">\n");
3151         }
3152         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3153         break;
3154     case OP_NEXTSTATE:
3155     case OP_DBSTATE:
3156         if (CopLINE(cCOPo))
3157             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3158                              (UV)CopLINE(cCOPo));
3159         if (CopSTASHPV(cCOPo))
3160             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3161                              CopSTASHPV(cCOPo));
3162         if (CopLABEL(cCOPo))
3163             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3164                              CopLABEL(cCOPo));
3165         break;
3166     case OP_ENTERLOOP:
3167         S_xmldump_attr(aTHX_ level, file, "redo=\"");
3168         if (cLOOPo->op_redoop)
3169             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3170         else
3171             PerlIO_printf(file, "DONE\"");
3172         S_xmldump_attr(aTHX_ level, file, "next=\"");
3173         if (cLOOPo->op_nextop)
3174             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3175         else
3176             PerlIO_printf(file, "DONE\"");
3177         S_xmldump_attr(aTHX_ level, file, "last=\"");
3178         if (cLOOPo->op_lastop)
3179             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3180         else
3181             PerlIO_printf(file, "DONE\"");
3182         break;
3183     case OP_COND_EXPR:
3184     case OP_RANGE:
3185     case OP_MAPWHILE:
3186     case OP_GREPWHILE:
3187     case OP_OR:
3188     case OP_AND:
3189         S_xmldump_attr(aTHX_ level, file, "other=\"");
3190         if (cLOGOPo->op_other)
3191             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3192         else
3193             PerlIO_printf(file, "DONE\"");
3194         break;
3195     case OP_LEAVE:
3196     case OP_LEAVEEVAL:
3197     case OP_LEAVESUB:
3198     case OP_LEAVESUBLV:
3199     case OP_LEAVEWRITE:
3200     case OP_SCOPE:
3201         if (o->op_private & OPpREFCOUNTED)
3202             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3203         break;
3204     default:
3205         break;
3206     }
3207
3208     if (PL_madskills && o->op_madprop) {
3209         char prevkey = '\0';
3210         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3211         const MADPROP* mp = o->op_madprop;
3212
3213         if (!contents) {
3214             contents = 1;
3215             PerlIO_printf(file, ">\n");
3216         }
3217         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3218         level++;
3219         while (mp) {
3220             char tmp = mp->mad_key;
3221             sv_setpvs(tmpsv,"\"");
3222             if (tmp)
3223                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3224             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3225                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3226             else
3227                 prevkey = tmp;
3228             sv_catpv(tmpsv, "\"");
3229             switch (mp->mad_type) {
3230             case MAD_NULL:
3231                 sv_catpv(tmpsv, "NULL");
3232                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3233                 break;
3234             case MAD_PV:
3235                 sv_catpv(tmpsv, " val=\"");
3236                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3237                 sv_catpv(tmpsv, "\"");
3238                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3239                 break;
3240             case MAD_SV:
3241                 sv_catpv(tmpsv, " val=\"");
3242                 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3243                 sv_catpv(tmpsv, "\"");
3244                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3245                 break;
3246             case MAD_OP:
3247                 if ((OP*)mp->mad_val) {
3248                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3249                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3250                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3251                 }
3252                 break;
3253             default:
3254                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3255                 break;
3256             }
3257             mp = mp->mad_next;
3258         }
3259         level--;
3260         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3261
3262         SvREFCNT_dec(tmpsv);
3263     }
3264
3265     switch (o->op_type) {
3266     case OP_PUSHRE:
3267     case OP_MATCH:
3268     case OP_QR:
3269     case OP_SUBST:
3270         if (!contents) {
3271             contents = 1;
3272             PerlIO_printf(file, ">\n");
3273         }
3274         do_pmop_xmldump(level, file, cPMOPo);
3275         break;
3276     default:
3277         break;
3278     }
3279
3280     if (o->op_flags & OPf_KIDS) {
3281         OP *kid;
3282         if (!contents) {
3283             contents = 1;
3284             PerlIO_printf(file, ">\n");
3285         }
3286         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3287             do_op_xmldump(level, file, kid);
3288     }
3289
3290     if (contents)
3291         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3292     else
3293         PerlIO_printf(file, " />\n");
3294 }
3295
3296 void
3297 Perl_op_xmldump(pTHX_ const OP *o)
3298 {
3299     PERL_ARGS_ASSERT_OP_XMLDUMP;
3300
3301     do_op_xmldump(0, PL_xmlfp, o);
3302 }
3303 #endif
3304
3305 /*
3306  * Local variables:
3307  * c-indentation-style: bsd
3308  * c-basic-offset: 4
3309  * indent-tabs-mode: t
3310  * End:
3311  *
3312  * ex: set ts=8 sts=4 sw=4 noet:
3313  */