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