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