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