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