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