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