This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #123223] Make PADNAME a separate type
[perl5.git] / dump.c
1 /*    dump.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *  'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13  *   it has not been hard for me to read your mind and memory.'
14  *
15  *     [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
16  */
17
18 /* This file contains utility routines to dump the contents of SV and OP
19  * structures, as used by command-line options like -Dt and -Dx, and
20  * by Devel::Peek.
21  *
22  * It also holds the debugging version of the  runops function.
23
24 =head1 Display and Dump functions
25  */
26
27 #include "EXTERN.h"
28 #define PERL_IN_DUMP_C
29 #include "perl.h"
30 #include "regcomp.h"
31
32 static const char* const svtypenames[SVt_LAST] = {
33     "NULL",
34     "IV",
35     "NV",
36     "PV",
37     "INVLIST",
38     "PVIV",
39     "PVNV",
40     "PVMG",
41     "REGEXP",
42     "PVGV",
43     "PVLV",
44     "PVAV",
45     "PVHV",
46     "PVCV",
47     "PVFM",
48     "PVIO"
49 };
50
51
52 static const char* const svshorttypenames[SVt_LAST] = {
53     "UNDEF",
54     "IV",
55     "NV",
56     "PV",
57     "INVLST",
58     "PVIV",
59     "PVNV",
60     "PVMG",
61     "REGEXP",
62     "GV",
63     "PVLV",
64     "AV",
65     "HV",
66     "CV",
67     "FM",
68     "IO"
69 };
70
71 struct flag_to_name {
72     U32 flag;
73     const char *name;
74 };
75
76 static void
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78                const struct flag_to_name *const end)
79 {
80     do {
81         if (flags & start->flag)
82             sv_catpv(sv, start->name);
83     } while (++start < end);
84 }
85
86 #define append_flags(sv, f, flags) \
87     S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
88
89 #define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
90                               (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
91                               PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
92                               | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
93
94 /*
95 =for apidoc pv_escape
96
97 Escapes at most the first "count" chars of pv and puts the results into
98 dsv such that the size of the escaped string will not exceed "max" chars
99 and will not contain any incomplete escape sequences.  The number of bytes
100 escaped will be returned in the STRLEN *escaped parameter if it is not null.
101 When the dsv parameter is null no escaping actually occurs, but the number
102 of bytes that would be escaped were it not null will be calculated.
103
104 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
105 will also be escaped.
106
107 Normally the SV will be cleared before the escaped string is prepared,
108 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
109
110 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
111 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
112 using C<is_utf8_string()> to determine if it is Unicode.
113
114 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
115 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
116 non-ASCII chars will be escaped using this style; otherwise, only chars above
117 255 will be so escaped; other non printable chars will use octal or
118 common escaped patterns like C<\n>.
119 Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
120 then all chars below 255 will be treated as printable and
121 will be output as literals.
122
123 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
124 string will be escaped, regardless of max.  If the output is to be in hex,
125 then it will be returned as a plain hex
126 sequence.  Thus the output will either be a single char,
127 an octal escape sequence, a special escape like C<\n> or a hex value.
128
129 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
130 not a '\\'.  This is because regexes very often contain backslashed
131 sequences, whereas '%' is not a particularly common character in patterns.
132
133 Returns a pointer to the escaped text as held by dsv.
134
135 =cut
136 */
137 #define PV_ESCAPE_OCTBUFSIZE 32
138
139 char *
140 Perl_pv_escape( pTHX_ SV *dsv, char const * const str, 
141                 const STRLEN count, const STRLEN max, 
142                 STRLEN * const escaped, const U32 flags ) 
143 {
144     const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
145     const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
146     char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
147     STRLEN wrote = 0;    /* chars written so far */
148     STRLEN chsize = 0;   /* size of data to be written */
149     STRLEN readsize = 1; /* size of data just read */
150     bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
151     const char *pv  = str;
152     const char * const end = pv + count; /* end of string */
153     octbuf[0] = esc;
154
155     PERL_ARGS_ASSERT_PV_ESCAPE;
156
157     if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
158             /* This won't alter the UTF-8 flag */
159             sv_setpvs(dsv, "");
160     }
161     
162     if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
163         isuni = 1;
164     
165     for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
166         const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
167         const U8 c = (U8)u & 0xFF;
168         
169         if ( ( u > 255 )
170           || (flags & PERL_PV_ESCAPE_ALL)
171           || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
172         {
173             if (flags & PERL_PV_ESCAPE_FIRSTCHAR) 
174                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
175                                       "%"UVxf, u);
176             else
177                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
178                                       ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
179                                       ? "%cx%02"UVxf
180                                       : "%cx{%02"UVxf"}", esc, u);
181
182         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
183             chsize = 1;            
184         } else {         
185             if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
186                 chsize = 2;
187                 switch (c) {
188                 
189                 case '\\' : /* FALLTHROUGH */
190                 case '%'  : if ( c == esc )  {
191                                 octbuf[1] = esc;  
192                             } else {
193                                 chsize = 1;
194                             }
195                             break;
196                 case '\v' : octbuf[1] = 'v';  break;
197                 case '\t' : octbuf[1] = 't';  break;
198                 case '\r' : octbuf[1] = 'r';  break;
199                 case '\n' : octbuf[1] = 'n';  break;
200                 case '\f' : octbuf[1] = 'f';  break;
201                 case '"'  : 
202                         if ( dq == '"' ) 
203                                 octbuf[1] = '"';
204                         else 
205                             chsize = 1;
206                         break;
207                 default:
208                      if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
209                         chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
210                                       isuni ? "%cx{%02"UVxf"}" : "%cx%02"UVxf,
211                                       esc, u);
212                      }
213                      else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
214                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
215                                                   "%c%03o", esc, c);
216                         else
217                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 
218                                                   "%c%o", esc, c);
219                 }
220             } else {
221                 chsize = 1;
222             }
223         }
224         if ( max && (wrote + chsize > max) ) {
225             break;
226         } else if (chsize > 1) {
227             if (dsv)
228                 sv_catpvn(dsv, octbuf, chsize);
229             wrote += chsize;
230         } else {
231             /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
232                can be appended raw to the dsv. If dsv happens to be
233                UTF-8 then we need catpvf to upgrade them for us.
234                Or add a new API call sv_catpvc(). Think about that name, and
235                how to keep it clear that it's unlike the s of catpvs, which is
236                really an array of octets, not a string.  */
237             if (dsv)
238                 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
239             wrote++;
240         }
241         if ( flags & PERL_PV_ESCAPE_FIRSTCHAR ) 
242             break;
243     }
244     if (escaped != NULL)
245         *escaped= pv - str;
246     return dsv ? SvPVX(dsv) : NULL;
247 }
248 /*
249 =for apidoc pv_pretty
250
251 Converts a string into something presentable, handling escaping via
252 pv_escape() and supporting quoting and ellipses.
253
254 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be 
255 double quoted with any double quotes in the string escaped.  Otherwise
256 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
257 angle brackets. 
258
259 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
260 string were output then an ellipsis C<...> will be appended to the
261 string.  Note that this happens AFTER it has been quoted.
262
263 If start_color is non-null then it will be inserted after the opening
264 quote (if there is one) but before the escaped text.  If end_color
265 is non-null then it will be inserted after the escaped text but before
266 any quotes or ellipses.
267
268 Returns a pointer to the prettified text as held by dsv.
269
270 =cut           
271 */
272
273 char *
274 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, 
275   const STRLEN max, char const * const start_color, char const * const end_color, 
276   const U32 flags ) 
277 {
278     const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
279                              (flags & PERL_PV_PRETTY_LTGT)  ? "<>" : NULL);
280     STRLEN escaped;
281     STRLEN max_adjust= 0;
282     STRLEN orig_cur;
283  
284     PERL_ARGS_ASSERT_PV_PRETTY;
285    
286     if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
287         /* This won't alter the UTF-8 flag */
288         sv_setpvs(dsv, "");
289     }
290     orig_cur= SvCUR(dsv);
291
292     if ( quotes )
293         Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
294         
295     if ( start_color != NULL ) 
296         sv_catpv(dsv, start_color);
297
298     if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
299         if (quotes)
300             max_adjust += 2;
301         assert(max > max_adjust);
302         pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
303         if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
304             max_adjust += 3;
305         assert(max > max_adjust);
306     }
307
308     pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
309
310     if ( end_color != NULL ) 
311         sv_catpv(dsv, end_color);
312
313     if ( quotes )
314         Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
315     
316     if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
317             sv_catpvs(dsv, "...");
318
319     if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
320         while( SvCUR(dsv) - orig_cur < max )
321             sv_catpvs(dsv," ");
322     }
323  
324     return SvPVX(dsv);
325 }
326
327 /*
328 =for apidoc pv_display
329
330 Similar to
331
332   pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
333
334 except that an additional "\0" will be appended to the string when
335 len > cur and pv[cur] is "\0".
336
337 Note that the final string may be up to 7 chars longer than pvlim.
338
339 =cut
340 */
341
342 char *
343 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
344 {
345     PERL_ARGS_ASSERT_PV_DISPLAY;
346
347     pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
348     if (len > cur && pv[cur] == '\0')
349             sv_catpvs( dsv, "\\0");
350     return SvPVX(dsv);
351 }
352
353 char *
354 Perl_sv_peek(pTHX_ SV *sv)
355 {
356     dVAR;
357     SV * const t = sv_newmortal();
358     int unref = 0;
359     U32 type;
360
361     sv_setpvs(t, "");
362   retry:
363     if (!sv) {
364         sv_catpv(t, "VOID");
365         goto finish;
366     }
367     else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
368         /* detect data corruption under memory poisoning */
369         sv_catpv(t, "WILD");
370         goto finish;
371     }
372     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
373         if (sv == &PL_sv_undef) {
374             sv_catpv(t, "SV_UNDEF");
375             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
376                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
377                 SvREADONLY(sv))
378                 goto finish;
379         }
380         else if (sv == &PL_sv_no) {
381             sv_catpv(t, "SV_NO");
382             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
383                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
384                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
385                                   SVp_POK|SVp_NOK)) &&
386                 SvCUR(sv) == 0 &&
387                 SvNVX(sv) == 0.0)
388                 goto finish;
389         }
390         else if (sv == &PL_sv_yes) {
391             sv_catpv(t, "SV_YES");
392             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
393                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
394                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
395                                   SVp_POK|SVp_NOK)) &&
396                 SvCUR(sv) == 1 &&
397                 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
398                 SvNVX(sv) == 1.0)
399                 goto finish;
400         }
401         else {
402             sv_catpv(t, "SV_PLACEHOLDER");
403             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
404                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
405                 SvREADONLY(sv))
406                 goto finish;
407         }
408         sv_catpv(t, ":");
409     }
410     else if (SvREFCNT(sv) == 0) {
411         sv_catpv(t, "(");
412         unref++;
413     }
414     else if (DEBUG_R_TEST_) {
415         int is_tmp = 0;
416         SSize_t ix;
417         /* is this SV on the tmps stack? */
418         for (ix=PL_tmps_ix; ix>=0; ix--) {
419             if (PL_tmps_stack[ix] == sv) {
420                 is_tmp = 1;
421                 break;
422             }
423         }
424         if (SvREFCNT(sv) > 1)
425             Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
426                     is_tmp ? "T" : "");
427         else if (is_tmp)
428             sv_catpv(t, "<T>");
429     }
430
431     if (SvROK(sv)) {
432         sv_catpv(t, "\\");
433         if (SvCUR(t) + unref > 10) {
434             SvCUR_set(t, unref + 3);
435             *SvEND(t) = '\0';
436             sv_catpv(t, "...");
437             goto finish;
438         }
439         sv = SvRV(sv);
440         goto retry;
441     }
442     type = SvTYPE(sv);
443     if (type == SVt_PVCV) {
444         SV * const tmp = newSVpvs_flags("", SVs_TEMP);
445         GV* gvcv = CvGV(sv);
446         Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
447                        ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
448                        : "");
449         goto finish;
450     } else if (type < SVt_LAST) {
451         sv_catpv(t, svshorttypenames[type]);
452
453         if (type == SVt_NULL)
454             goto finish;
455     } else {
456         sv_catpv(t, "FREED");
457         goto finish;
458     }
459
460     if (SvPOKp(sv)) {
461         if (!SvPVX_const(sv))
462             sv_catpv(t, "(null)");
463         else {
464             SV * const tmp = newSVpvs("");
465             sv_catpv(t, "(");
466             if (SvOOK(sv)) {
467                 STRLEN delta;
468                 SvOOK_offset(sv, delta);
469                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
470             }
471             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
472             if (SvUTF8(sv))
473                 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
474                                sv_uni_display(tmp, sv, 6 * SvCUR(sv),
475                                               UNI_DISPLAY_QQ));
476             SvREFCNT_dec_NN(tmp);
477         }
478     }
479     else if (SvNOKp(sv)) {
480         STORE_NUMERIC_LOCAL_SET_STANDARD();
481         Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
482         RESTORE_NUMERIC_LOCAL();
483     }
484     else if (SvIOKp(sv)) {
485         if (SvIsUV(sv))
486             Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
487         else
488             Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
489     }
490     else
491         sv_catpv(t, "()");
492
493   finish:
494     while (unref--)
495         sv_catpv(t, ")");
496     if (TAINTING_get && sv && SvTAINTED(sv))
497         sv_catpv(t, " [tainted]");
498     return SvPV_nolen(t);
499 }
500
501 /*
502 =head1 Debugging Utilities
503 */
504
505 void
506 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
507 {
508     va_list args;
509     PERL_ARGS_ASSERT_DUMP_INDENT;
510     va_start(args, pat);
511     dump_vindent(level, file, pat, &args);
512     va_end(args);
513 }
514
515 void
516 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
517 {
518     PERL_ARGS_ASSERT_DUMP_VINDENT;
519     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
520     PerlIO_vprintf(file, pat, *args);
521 }
522
523 /*
524 =for apidoc dump_all
525
526 Dumps the entire optree of the current program starting at C<PL_main_root> to 
527 C<STDERR>.  Also dumps the optrees for all visible subroutines in
528 C<PL_defstash>.
529
530 =cut
531 */
532
533 void
534 Perl_dump_all(pTHX)
535 {
536     dump_all_perl(FALSE);
537 }
538
539 void
540 Perl_dump_all_perl(pTHX_ bool justperl)
541 {
542     PerlIO_setlinebuf(Perl_debug_log);
543     if (PL_main_root)
544         op_dump(PL_main_root);
545     dump_packsubs_perl(PL_defstash, justperl);
546 }
547
548 /*
549 =for apidoc dump_packsubs
550
551 Dumps the optrees for all visible subroutines in C<stash>.
552
553 =cut
554 */
555
556 void
557 Perl_dump_packsubs(pTHX_ const HV *stash)
558 {
559     PERL_ARGS_ASSERT_DUMP_PACKSUBS;
560     dump_packsubs_perl(stash, FALSE);
561 }
562
563 void
564 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
565 {
566     I32 i;
567
568     PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
569
570     if (!HvARRAY(stash))
571         return;
572     for (i = 0; i <= (I32) HvMAX(stash); i++) {
573         const HE *entry;
574         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
575             const GV * const gv = (const GV *)HeVAL(entry);
576             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
577                 continue;
578             if (GvCVu(gv))
579                 dump_sub_perl(gv, justperl);
580             if (GvFORM(gv))
581                 dump_form(gv);
582             if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
583                 const HV * const hv = GvHV(gv);
584                 if (hv && (hv != PL_defstash))
585                     dump_packsubs_perl(hv, justperl); /* nested package */
586             }
587         }
588     }
589 }
590
591 void
592 Perl_dump_sub(pTHX_ const GV *gv)
593 {
594     PERL_ARGS_ASSERT_DUMP_SUB;
595     dump_sub_perl(gv, FALSE);
596 }
597
598 void
599 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
600 {
601     STRLEN len;
602     SV * const sv = newSVpvs_flags("", SVs_TEMP);
603     SV *tmpsv;
604     const char * name;
605
606     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
607
608     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
609         return;
610
611     tmpsv = newSVpvs_flags("", SVs_TEMP);
612     gv_fullname3(sv, gv, NULL);
613     name = SvPV_const(sv, len);
614     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
615                      generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
616     if (CvISXSUB(GvCV(gv)))
617         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
618             PTR2UV(CvXSUB(GvCV(gv))),
619             (int)CvXSUBANY(GvCV(gv)).any_i32);
620     else if (CvROOT(GvCV(gv)))
621         op_dump(CvROOT(GvCV(gv)));
622     else
623         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
624 }
625
626 void
627 Perl_dump_form(pTHX_ const GV *gv)
628 {
629     SV * const sv = sv_newmortal();
630
631     PERL_ARGS_ASSERT_DUMP_FORM;
632
633     gv_fullname3(sv, gv, NULL);
634     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
635     if (CvROOT(GvFORM(gv)))
636         op_dump(CvROOT(GvFORM(gv)));
637     else
638         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
639 }
640
641 void
642 Perl_dump_eval(pTHX)
643 {
644     op_dump(PL_eval_root);
645 }
646
647 void
648 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
649 {
650     char ch;
651
652     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
653
654     if (!pm) {
655         Perl_dump_indent(aTHX_ level, file, "{}\n");
656         return;
657     }
658     Perl_dump_indent(aTHX_ level, file, "{\n");
659     level++;
660     if (pm->op_pmflags & PMf_ONCE)
661         ch = '?';
662     else
663         ch = '/';
664     if (PM_GETRE(pm))
665         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n",
666              ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch,
667              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
668     else
669         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
670     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
671         Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
672         op_dump(pm->op_pmreplrootu.op_pmreplroot);
673     }
674     if (pm->op_code_list) {
675         if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
676             Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
677             do_op_dump(level, file, pm->op_code_list);
678         }
679         else
680             Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
681                                     PTR2UV(pm->op_code_list));
682     }
683     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
684         SV * const tmpsv = pm_description(pm);
685         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
686         SvREFCNT_dec_NN(tmpsv);
687     }
688
689     Perl_dump_indent(aTHX_ level-1, file, "}\n");
690 }
691
692 const struct flag_to_name pmflags_flags_names[] = {
693     {PMf_CONST, ",CONST"},
694     {PMf_KEEP, ",KEEP"},
695     {PMf_GLOBAL, ",GLOBAL"},
696     {PMf_CONTINUE, ",CONTINUE"},
697     {PMf_RETAINT, ",RETAINT"},
698     {PMf_EVAL, ",EVAL"},
699     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
700     {PMf_HAS_CV, ",HAS_CV"},
701     {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
702     {PMf_IS_QR, ",IS_QR"}
703 };
704
705 static SV *
706 S_pm_description(pTHX_ const PMOP *pm)
707 {
708     SV * const desc = newSVpvs("");
709     const REGEXP * const regex = PM_GETRE(pm);
710     const U32 pmflags = pm->op_pmflags;
711
712     PERL_ARGS_ASSERT_PM_DESCRIPTION;
713
714     if (pmflags & PMf_ONCE)
715         sv_catpv(desc, ",ONCE");
716 #ifdef USE_ITHREADS
717     if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
718         sv_catpv(desc, ":USED");
719 #else
720     if (pmflags & PMf_USED)
721         sv_catpv(desc, ":USED");
722 #endif
723
724     if (regex) {
725         if (RX_ISTAINTED(regex))
726             sv_catpv(desc, ",TAINTED");
727         if (RX_CHECK_SUBSTR(regex)) {
728             if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
729                 sv_catpv(desc, ",SCANFIRST");
730             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
731                 sv_catpv(desc, ",ALL");
732         }
733         if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
734             sv_catpv(desc, ",SKIPWHITE");
735     }
736
737     append_flags(desc, pmflags, pmflags_flags_names);
738     return desc;
739 }
740
741 void
742 Perl_pmop_dump(pTHX_ PMOP *pm)
743 {
744     do_pmop_dump(0, Perl_debug_log, pm);
745 }
746
747 /* Return a unique integer to represent the address of op o.
748  * If it already exists in PL_op_sequence, just return it;
749  * otherwise add it.
750  *  *** Note that this isn't thread-safe */
751
752 STATIC UV
753 S_sequence_num(pTHX_ const OP *o)
754 {
755     dVAR;
756     SV     *op,
757           **seq;
758     const char *key;
759     STRLEN  len;
760     if (!o)
761         return 0;
762     op = newSVuv(PTR2UV(o));
763     sv_2mortal(op);
764     key = SvPV_const(op, len);
765     if (!PL_op_sequence)
766         PL_op_sequence = newHV();
767     seq = hv_fetch(PL_op_sequence, key, len, 0);
768     if (seq)
769         return SvUV(*seq);
770     (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
771     return PL_op_seq;
772 }
773
774
775
776
777
778 const struct flag_to_name op_flags_names[] = {
779     {OPf_KIDS, ",KIDS"},
780     {OPf_PARENS, ",PARENS"},
781     {OPf_REF, ",REF"},
782     {OPf_MOD, ",MOD"},
783     {OPf_STACKED, ",STACKED"},
784     {OPf_SPECIAL, ",SPECIAL"}
785 };
786
787
788 void
789 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
790 {
791     UV      seq;
792     const OPCODE optype = o->op_type;
793
794     PERL_ARGS_ASSERT_DO_OP_DUMP;
795
796     Perl_dump_indent(aTHX_ level, file, "{\n");
797     level++;
798     seq = sequence_num(o);
799     if (seq)
800         PerlIO_printf(file, "%-4"UVuf, seq);
801     else
802         PerlIO_printf(file, "????");
803     PerlIO_printf(file,
804                   "%*sTYPE = %s  ===> ",
805                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
806     if (o->op_next)
807         PerlIO_printf(file,
808                         o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
809                                 sequence_num(o->op_next));
810     else
811         PerlIO_printf(file, "NULL\n");
812     if (o->op_targ) {
813         if (optype == OP_NULL) {
814             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
815         }
816         else
817             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
818     }
819 #ifdef DUMPADDR
820     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
821 #endif
822
823     if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
824         SV * const tmpsv = newSVpvs("");
825         switch (o->op_flags & OPf_WANT) {
826         case OPf_WANT_VOID:
827             sv_catpv(tmpsv, ",VOID");
828             break;
829         case OPf_WANT_SCALAR:
830             sv_catpv(tmpsv, ",SCALAR");
831             break;
832         case OPf_WANT_LIST:
833             sv_catpv(tmpsv, ",LIST");
834             break;
835         default:
836             sv_catpv(tmpsv, ",UNKNOWN");
837             break;
838         }
839         append_flags(tmpsv, o->op_flags, op_flags_names);
840         if (o->op_slabbed)  sv_catpvs(tmpsv, ",SLABBED");
841         if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
842         if (o->op_static)   sv_catpvs(tmpsv, ",STATIC");
843         if (o->op_folded)   sv_catpvs(tmpsv, ",FOLDED");
844         if (o->op_lastsib)  sv_catpvs(tmpsv, ",LASTSIB");
845         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
846                          SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
847     }
848
849     if (o->op_private) {
850         U16 oppriv = o->op_private;
851         I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
852         SV * tmpsv = NULL;
853
854         if (op_ix != -1) {
855             U16 stop = 0;
856             tmpsv = newSVpvs("");
857             for (; !stop; op_ix++) {
858                 U16 entry = PL_op_private_bitdefs[op_ix];
859                 U16 bit = (entry >> 2) & 7;
860                 U16 ix = entry >> 5;
861
862                 stop = (entry & 1);
863
864                 if (entry & 2) {
865                     /* bitfield */
866                     I16 const *p = &PL_op_private_bitfields[ix];
867                     U16 bitmin = (U16) *p++;
868                     I16 label = *p++;
869                     I16 enum_label;
870                     U16 mask = 0;
871                     U16 i;
872                     U16 val;
873
874                     for (i = bitmin; i<= bit; i++)
875                         mask |= (1<<i);
876                     bit = bitmin;
877                     val = (oppriv & mask);
878
879                     if (   label != -1
880                         && PL_op_private_labels[label] == '-'
881                         && PL_op_private_labels[label+1] == '\0'
882                     )
883                         /* display as raw number */
884                         continue;
885
886                     oppriv -= val;
887                     val >>= bit;
888                     enum_label = -1;
889                     while (*p != -1) {
890                         if (val == *p++) {
891                             enum_label = *p;
892                             break;
893                         }
894                         p++;
895                     }
896                     if (val == 0 && enum_label == -1)
897                         /* don't display anonymous zero values */
898                         continue;
899
900                     sv_catpv(tmpsv, ",");
901                     if (label != -1) {
902                         sv_catpv(tmpsv, &PL_op_private_labels[label]);
903                         sv_catpv(tmpsv, "=");
904                     }
905                     sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
906
907                 }
908                 else {
909                     /* bit flag */
910                     if (   oppriv & (1<<bit)
911                         && !(PL_op_private_labels[ix] == '-'
912                              && PL_op_private_labels[ix+1] == '\0'))
913                     {
914                         oppriv -= (1<<bit);
915                         sv_catpv(tmpsv, ",");
916                         sv_catpv(tmpsv, &PL_op_private_labels[ix]);
917                     }
918                 }
919             }
920             if (oppriv) {
921                 sv_catpv(tmpsv, ",");
922                 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
923             }
924         }
925         if (tmpsv && SvCUR(tmpsv)) {
926             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
927         } else
928             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
929                              (UV)oppriv);
930     }
931
932     switch (optype) {
933     case OP_AELEMFAST:
934     case OP_GVSV:
935     case OP_GV:
936 #ifdef USE_ITHREADS
937         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
938 #else
939         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
940             if (cSVOPo->op_sv) {
941       STRLEN len;
942       const char * name;
943       SV * const tmpsv  = newSVpvs_flags("", SVs_TEMP);
944       SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
945                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
946       name = SvPV_const(tmpsv, len);
947                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
948                        generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
949             }
950             else
951                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
952         }
953 #endif
954         break;
955     case OP_CONST:
956     case OP_HINTSEVAL:
957     case OP_METHOD_NAMED:
958     case OP_METHOD_SUPER:
959 #ifndef USE_ITHREADS
960         /* with ITHREADS, consts are stored in the pad, and the right pad
961          * may not be active here, so skip */
962         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
963 #endif
964         break;
965     case OP_NULL:
966         if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
967             break;
968         /* FALLTHROUGH */
969     case OP_NEXTSTATE:
970     case OP_DBSTATE:
971         if (CopLINE(cCOPo))
972             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
973                              (UV)CopLINE(cCOPo));
974     if (CopSTASHPV(cCOPo)) {
975         SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
976         HV *stash = CopSTASH(cCOPo);
977         const char * const hvname = HvNAME_get(stash);
978         
979             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
980                            generic_pv_escape(tmpsv, hvname,
981                               HvNAMELEN(stash), HvNAMEUTF8(stash)));
982     }
983   if (CopLABEL(cCOPo)) {
984        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
985        STRLEN label_len;
986        U32 label_flags;
987        const char *label = CopLABEL_len_flags(cCOPo,
988                                                 &label_len, &label_flags);
989        Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
990                            generic_pv_escape( tmpsv, label, label_len,
991                                       (label_flags & SVf_UTF8)));
992    }
993         Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
994                                              cCOPo->cop_seq);
995         break;
996     case OP_ENTERLOOP:
997         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
998         if (cLOOPo->op_redoop)
999             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1000         else
1001             PerlIO_printf(file, "DONE\n");
1002         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1003         if (cLOOPo->op_nextop)
1004             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1005         else
1006             PerlIO_printf(file, "DONE\n");
1007         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1008         if (cLOOPo->op_lastop)
1009             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1010         else
1011             PerlIO_printf(file, "DONE\n");
1012         break;
1013     case OP_COND_EXPR:
1014     case OP_RANGE:
1015     case OP_MAPWHILE:
1016     case OP_GREPWHILE:
1017     case OP_OR:
1018     case OP_AND:
1019         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1020         if (cLOGOPo->op_other)
1021             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1022         else
1023             PerlIO_printf(file, "DONE\n");
1024         break;
1025     case OP_PUSHRE:
1026     case OP_MATCH:
1027     case OP_QR:
1028     case OP_SUBST:
1029         do_pmop_dump(level, file, cPMOPo);
1030         break;
1031     case OP_LEAVE:
1032     case OP_LEAVEEVAL:
1033     case OP_LEAVESUB:
1034     case OP_LEAVESUBLV:
1035     case OP_LEAVEWRITE:
1036     case OP_SCOPE:
1037         if (o->op_private & OPpREFCOUNTED)
1038             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1039         break;
1040     default:
1041         break;
1042     }
1043     if (o->op_flags & OPf_KIDS) {
1044         OP *kid;
1045         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1046             do_op_dump(level, file, kid);
1047     }
1048     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1049 }
1050
1051 /*
1052 =for apidoc op_dump
1053
1054 Dumps the optree starting at OP C<o> to C<STDERR>.
1055
1056 =cut
1057 */
1058
1059 void
1060 Perl_op_dump(pTHX_ const OP *o)
1061 {
1062     PERL_ARGS_ASSERT_OP_DUMP;
1063     do_op_dump(0, Perl_debug_log, o);
1064 }
1065
1066 void
1067 Perl_gv_dump(pTHX_ GV *gv)
1068 {
1069     STRLEN len;
1070     const char* name;
1071     SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1072
1073
1074     PERL_ARGS_ASSERT_GV_DUMP;
1075
1076     if (!gv) {
1077         PerlIO_printf(Perl_debug_log, "{}\n");
1078         return;
1079     }
1080     sv = sv_newmortal();
1081     PerlIO_printf(Perl_debug_log, "{\n");
1082     gv_fullname3(sv, gv, NULL);
1083     name = SvPV_const(sv, len);
1084     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1085                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1086     if (gv != GvEGV(gv)) {
1087         gv_efullname3(sv, GvEGV(gv), NULL);
1088         name = SvPV_const(sv, len);
1089         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1090                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1091     }
1092     PerlIO_putc(Perl_debug_log, '\n');
1093     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1094 }
1095
1096
1097 /* map magic types to the symbolic names
1098  * (with the PERL_MAGIC_ prefixed stripped)
1099  */
1100
1101 static const struct { const char type; const char *name; } magic_names[] = {
1102 #include "mg_names.c"
1103         /* this null string terminates the list */
1104         { 0,                         NULL },
1105 };
1106
1107 void
1108 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1109 {
1110     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1111
1112     for (; mg; mg = mg->mg_moremagic) {
1113         Perl_dump_indent(aTHX_ level, file,
1114                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1115         if (mg->mg_virtual) {
1116             const MGVTBL * const v = mg->mg_virtual;
1117             if (v >= PL_magic_vtables
1118                 && v < PL_magic_vtables + magic_vtable_max) {
1119                 const U32 i = v - PL_magic_vtables;
1120                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1121             }
1122             else
1123                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1124         }
1125         else
1126             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1127
1128         if (mg->mg_private)
1129             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1130
1131         {
1132             int n;
1133             const char *name = NULL;
1134             for (n = 0; magic_names[n].name; n++) {
1135                 if (mg->mg_type == magic_names[n].type) {
1136                     name = magic_names[n].name;
1137                     break;
1138                 }
1139             }
1140             if (name)
1141                 Perl_dump_indent(aTHX_ level, file,
1142                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1143             else
1144                 Perl_dump_indent(aTHX_ level, file,
1145                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1146         }
1147
1148         if (mg->mg_flags) {
1149             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1150             if (mg->mg_type == PERL_MAGIC_envelem &&
1151                 mg->mg_flags & MGf_TAINTEDDIR)
1152                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1153             if (mg->mg_type == PERL_MAGIC_regex_global &&
1154                 mg->mg_flags & MGf_MINMATCH)
1155                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1156             if (mg->mg_flags & MGf_REFCOUNTED)
1157                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1158             if (mg->mg_flags & MGf_GSKIP)
1159                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1160             if (mg->mg_flags & MGf_COPY)
1161                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1162             if (mg->mg_flags & MGf_DUP)
1163                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1164             if (mg->mg_flags & MGf_LOCAL)
1165                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1166             if (mg->mg_type == PERL_MAGIC_regex_global &&
1167                 mg->mg_flags & MGf_BYTES)
1168                 Perl_dump_indent(aTHX_ level, file, "      BYTES\n");
1169         }
1170         if (mg->mg_obj) {
1171             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1172                 PTR2UV(mg->mg_obj));
1173             if (mg->mg_type == PERL_MAGIC_qr) {
1174                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1175                 SV * const dsv = sv_newmortal();
1176                 const char * const s
1177                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1178                     60, NULL, NULL,
1179                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1180                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1181                 );
1182                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1183                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1184                         (IV)RX_REFCNT(re));
1185             }
1186             if (mg->mg_flags & MGf_REFCOUNTED)
1187                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1188         }
1189         if (mg->mg_len)
1190             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1191         if (mg->mg_ptr) {
1192             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1193             if (mg->mg_len >= 0) {
1194                 if (mg->mg_type != PERL_MAGIC_utf8) {
1195                     SV * const sv = newSVpvs("");
1196                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1197                     SvREFCNT_dec_NN(sv);
1198                 }
1199             }
1200             else if (mg->mg_len == HEf_SVKEY) {
1201                 PerlIO_puts(file, " => HEf_SVKEY\n");
1202                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1203                            maxnest, dumpops, pvlim); /* MG is already +1 */
1204                 continue;
1205             }
1206             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1207             else
1208                 PerlIO_puts(
1209                   file,
1210                  " ???? - " __FILE__
1211                  " does not know how to handle this MG_LEN"
1212                 );
1213             PerlIO_putc(file, '\n');
1214         }
1215         if (mg->mg_type == PERL_MAGIC_utf8) {
1216             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1217             if (cache) {
1218                 IV i;
1219                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1220                     Perl_dump_indent(aTHX_ level, file,
1221                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1222                                      i,
1223                                      (UV)cache[i * 2],
1224                                      (UV)cache[i * 2 + 1]);
1225             }
1226         }
1227     }
1228 }
1229
1230 void
1231 Perl_magic_dump(pTHX_ const MAGIC *mg)
1232 {
1233     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1234 }
1235
1236 void
1237 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1238 {
1239     const char *hvname;
1240
1241     PERL_ARGS_ASSERT_DO_HV_DUMP;
1242
1243     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1244     if (sv && (hvname = HvNAME_get(sv)))
1245     {
1246         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1247            name which quite legally could contain insane things like tabs, newlines, nulls or
1248            other scary crap - this should produce sane results - except maybe for unicode package
1249            names - but we will wait for someone to file a bug on that - demerphq */
1250         SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1251         PerlIO_printf(file, "\t\"%s\"\n",
1252                               generic_pv_escape( tmpsv, hvname,
1253                                    HvNAMELEN(sv), HvNAMEUTF8(sv)));
1254     }
1255     else
1256         PerlIO_putc(file, '\n');
1257 }
1258
1259 void
1260 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1261 {
1262     PERL_ARGS_ASSERT_DO_GV_DUMP;
1263
1264     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1265     if (sv && GvNAME(sv)) {
1266         SV * const tmpsv = newSVpvs("");
1267         PerlIO_printf(file, "\t\"%s\"\n",
1268                               generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1269     }
1270     else
1271         PerlIO_putc(file, '\n');
1272 }
1273
1274 void
1275 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1276 {
1277     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1278
1279     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1280     if (sv && GvNAME(sv)) {
1281        SV *tmp = newSVpvs_flags("", SVs_TEMP);
1282         const char *hvname;
1283         HV * const stash = GvSTASH(sv);
1284         PerlIO_printf(file, "\t");
1285    /* TODO might have an extra \" here */
1286         if (stash && (hvname = HvNAME_get(stash))) {
1287             PerlIO_printf(file, "\"%s\" :: \"",
1288                                   generic_pv_escape(tmp, hvname,
1289                                       HvNAMELEN(stash), HvNAMEUTF8(stash)));
1290         }
1291         PerlIO_printf(file, "%s\"\n",
1292                               generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1293     }
1294     else
1295         PerlIO_putc(file, '\n');
1296 }
1297
1298 const struct flag_to_name first_sv_flags_names[] = {
1299     {SVs_TEMP, "TEMP,"},
1300     {SVs_OBJECT, "OBJECT,"},
1301     {SVs_GMG, "GMG,"},
1302     {SVs_SMG, "SMG,"},
1303     {SVs_RMG, "RMG,"},
1304     {SVf_IOK, "IOK,"},
1305     {SVf_NOK, "NOK,"},
1306     {SVf_POK, "POK,"}
1307 };
1308
1309 const struct flag_to_name second_sv_flags_names[] = {
1310     {SVf_OOK, "OOK,"},
1311     {SVf_FAKE, "FAKE,"},
1312     {SVf_READONLY, "READONLY,"},
1313     {SVf_PROTECT, "PROTECT,"},
1314     {SVf_BREAK, "BREAK,"},
1315     {SVp_IOK, "pIOK,"},
1316     {SVp_NOK, "pNOK,"},
1317     {SVp_POK, "pPOK,"}
1318 };
1319
1320 const struct flag_to_name cv_flags_names[] = {
1321     {CVf_ANON, "ANON,"},
1322     {CVf_UNIQUE, "UNIQUE,"},
1323     {CVf_CLONE, "CLONE,"},
1324     {CVf_CLONED, "CLONED,"},
1325     {CVf_CONST, "CONST,"},
1326     {CVf_NODEBUG, "NODEBUG,"},
1327     {CVf_LVALUE, "LVALUE,"},
1328     {CVf_METHOD, "METHOD,"},
1329     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1330     {CVf_CVGV_RC, "CVGV_RC,"},
1331     {CVf_DYNFILE, "DYNFILE,"},
1332     {CVf_AUTOLOAD, "AUTOLOAD,"},
1333     {CVf_HASEVAL, "HASEVAL,"},
1334     {CVf_SLABBED, "SLABBED,"},
1335     {CVf_NAMED, "NAMED,"},
1336     {CVf_LEXICAL, "LEXICAL,"},
1337     {CVf_ISXSUB, "ISXSUB,"}
1338 };
1339
1340 const struct flag_to_name hv_flags_names[] = {
1341     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1342     {SVphv_LAZYDEL, "LAZYDEL,"},
1343     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1344     {SVf_AMAGIC, "OVERLOAD,"},
1345     {SVphv_CLONEABLE, "CLONEABLE,"}
1346 };
1347
1348 const struct flag_to_name gp_flags_names[] = {
1349     {GVf_INTRO, "INTRO,"},
1350     {GVf_MULTI, "MULTI,"},
1351     {GVf_ASSUMECV, "ASSUMECV,"},
1352 };
1353
1354 const struct flag_to_name gp_flags_imported_names[] = {
1355     {GVf_IMPORTED_SV, " SV"},
1356     {GVf_IMPORTED_AV, " AV"},
1357     {GVf_IMPORTED_HV, " HV"},
1358     {GVf_IMPORTED_CV, " CV"},
1359 };
1360
1361 /* NOTE: this structure is mostly duplicative of one generated by
1362  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1363  * the two. - Yves */
1364 const struct flag_to_name regexp_extflags_names[] = {
1365     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1366     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1367     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1368     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1369     {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1370     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1371     {RXf_IS_ANCHORED,     "IS_ANCHORED,"},
1372     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1373     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1374     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1375     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1376     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1377     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1378     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1379     {RXf_SPLIT,           "SPLIT,"},
1380     {RXf_COPY_DONE,       "COPY_DONE,"},
1381     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1382     {RXf_TAINTED,         "TAINTED,"},
1383     {RXf_START_ONLY,      "START_ONLY,"},
1384     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1385     {RXf_WHITE,           "WHITE,"},
1386     {RXf_NULL,            "NULL,"},
1387 };
1388
1389 /* NOTE: this structure is mostly duplicative of one generated by
1390  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1391  * the two. - Yves */
1392 const struct flag_to_name regexp_core_intflags_names[] = {
1393     {PREGf_SKIP,            "SKIP,"},
1394     {PREGf_IMPLICIT,        "IMPLICIT,"},
1395     {PREGf_NAUGHTY,         "NAUGHTY,"},
1396     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1397     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1398     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1399     {PREGf_NOSCAN,          "NOSCAN,"},
1400     {PREGf_CANY_SEEN,       "CANY_SEEN,"},
1401     {PREGf_GPOS_SEEN,       "GPOS_SEEN,"},
1402     {PREGf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1403     {PREGf_ANCH_MBOL,       "ANCH_MBOL,"},
1404     {PREGf_ANCH_SBOL,       "ANCH_SBOL,"},
1405     {PREGf_ANCH_GPOS,       "ANCH_GPOS,"},
1406 };
1407
1408 void
1409 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1410 {
1411     SV *d;
1412     const char *s;
1413     U32 flags;
1414     U32 type;
1415
1416     PERL_ARGS_ASSERT_DO_SV_DUMP;
1417
1418     if (!sv) {
1419         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1420         return;
1421     }
1422
1423     flags = SvFLAGS(sv);
1424     type = SvTYPE(sv);
1425
1426     /* process general SV flags */
1427
1428     d = Perl_newSVpvf(aTHX_
1429                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1430                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1431                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1432                    (int)(PL_dumpindent*level), "");
1433
1434     if ((flags & SVs_PADSTALE))
1435             sv_catpv(d, "PADSTALE,");
1436     if ((flags & SVs_PADTMP))
1437             sv_catpv(d, "PADTMP,");
1438     append_flags(d, flags, first_sv_flags_names);
1439     if (flags & SVf_ROK)  {     
1440                                 sv_catpv(d, "ROK,");
1441         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1442     }
1443     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1444     append_flags(d, flags, second_sv_flags_names);
1445     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1446                            && type != SVt_PVAV) {
1447         if (SvPCS_IMPORTED(sv))
1448                                 sv_catpv(d, "PCS_IMPORTED,");
1449         else
1450                                 sv_catpv(d, "SCREAM,");
1451     }
1452
1453     /* process type-specific SV flags */
1454
1455     switch (type) {
1456     case SVt_PVCV:
1457     case SVt_PVFM:
1458         append_flags(d, CvFLAGS(sv), cv_flags_names);
1459         break;
1460     case SVt_PVHV:
1461         append_flags(d, flags, hv_flags_names);
1462         break;
1463     case SVt_PVGV:
1464     case SVt_PVLV:
1465         if (isGV_with_GP(sv)) {
1466             append_flags(d, GvFLAGS(sv), gp_flags_names);
1467         }
1468         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1469             sv_catpv(d, "IMPORT");
1470             if (GvIMPORTED(sv) == GVf_IMPORTED)
1471                 sv_catpv(d, "ALL,");
1472             else {
1473                 sv_catpv(d, "(");
1474                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1475                 sv_catpv(d, " ),");
1476             }
1477         }
1478         /* FALLTHROUGH */
1479     default:
1480     evaled_or_uv:
1481         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1482         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1483         break;
1484     case SVt_PVMG:
1485         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1486         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1487         /* FALLTHROUGH */
1488         goto evaled_or_uv;
1489     case SVt_PVAV:
1490         break;
1491     }
1492     /* SVphv_SHAREKEYS is also 0x20000000 */
1493     if ((type != SVt_PVHV) && SvUTF8(sv))
1494         sv_catpv(d, "UTF8");
1495
1496     if (*(SvEND(d) - 1) == ',') {
1497         SvCUR_set(d, SvCUR(d) - 1);
1498         SvPVX(d)[SvCUR(d)] = '\0';
1499     }
1500     sv_catpv(d, ")");
1501     s = SvPVX_const(d);
1502
1503     /* dump initial SV details */
1504
1505 #ifdef DEBUG_LEAKING_SCALARS
1506     Perl_dump_indent(aTHX_ level, file,
1507         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1508         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1509         sv->sv_debug_line,
1510         sv->sv_debug_inpad ? "for" : "by",
1511         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1512         PTR2UV(sv->sv_debug_parent),
1513         sv->sv_debug_serial
1514     );
1515 #endif
1516     Perl_dump_indent(aTHX_ level, file, "SV = ");
1517
1518     /* Dump SV type */
1519
1520     if (type < SVt_LAST) {
1521         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1522
1523         if (type ==  SVt_NULL) {
1524             SvREFCNT_dec_NN(d);
1525             return;
1526         }
1527     } else {
1528         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1529         SvREFCNT_dec_NN(d);
1530         return;
1531     }
1532
1533     /* Dump general SV fields */
1534
1535     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1536          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1537          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1538         || (type == SVt_IV && !SvROK(sv))) {
1539         if (SvIsUV(sv)
1540 #ifdef PERL_OLD_COPY_ON_WRITE
1541                        || SvIsCOW(sv)
1542 #endif
1543                                      )
1544             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1545         else
1546             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1547 #ifdef PERL_OLD_COPY_ON_WRITE
1548         if (SvIsCOW_shared_hash(sv))
1549             PerlIO_printf(file, "  (HASH)");
1550         else if (SvIsCOW_normal(sv))
1551             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1552 #endif
1553         PerlIO_putc(file, '\n');
1554     }
1555
1556     if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1557                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1558                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1559                || type == SVt_NV) {
1560         STORE_NUMERIC_LOCAL_SET_STANDARD();
1561         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1562         RESTORE_NUMERIC_LOCAL();
1563     }
1564
1565     if (SvROK(sv)) {
1566         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1567         if (nest < maxnest)
1568             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1569     }
1570
1571     if (type < SVt_PV) {
1572         SvREFCNT_dec_NN(d);
1573         return;
1574     }
1575
1576     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1577      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1578         const bool re = isREGEXP(sv);
1579         const char * const ptr =
1580             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1581         if (ptr) {
1582             STRLEN delta;
1583             if (SvOOK(sv)) {
1584                 SvOOK_offset(sv, delta);
1585                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1586                                  (UV) delta);
1587             } else {
1588                 delta = 0;
1589             }
1590             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(ptr));
1591             if (SvOOK(sv)) {
1592                 PerlIO_printf(file, "( %s . ) ",
1593                               pv_display(d, ptr - delta, delta, 0,
1594                                          pvlim));
1595             }
1596             if (type == SVt_INVLIST) {
1597                 PerlIO_printf(file, "\n");
1598                 /* 4 blanks indents 2 beyond the PV, etc */
1599                 _invlist_dump(file, level, "    ", sv);
1600             }
1601             else {
1602                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1603                                                      re ? 0 : SvLEN(sv),
1604                                                      pvlim));
1605                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1606                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1607                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1608                                                         UNI_DISPLAY_QQ));
1609                 PerlIO_printf(file, "\n");
1610             }
1611             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1612             if (!re)
1613                 Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
1614                                        (IV)SvLEN(sv));
1615 #ifdef PERL_NEW_COPY_ON_WRITE
1616             if (SvIsCOW(sv) && SvLEN(sv))
1617                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1618                                        CowREFCNT(sv));
1619 #endif
1620         }
1621         else
1622             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1623     }
1624
1625     if (type >= SVt_PVMG) {
1626         if (SvMAGIC(sv))
1627                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1628         if (SvSTASH(sv))
1629             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1630
1631         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1632             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1633         }
1634     }
1635
1636     /* Dump type-specific SV fields */
1637
1638     switch (type) {
1639     case SVt_PVAV:
1640         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1641         if (AvARRAY(sv) != AvALLOC(sv)) {
1642             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1643             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1644         }
1645         else
1646             PerlIO_putc(file, '\n');
1647         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1648         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1649         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n",
1650                                    SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1651         sv_setpvs(d, "");
1652         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1653         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1654         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1655                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1656         if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1657             SSize_t count;
1658             for (count = 0; count <=  av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1659                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1660
1661                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1662                 if (elt)
1663                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1664             }
1665         }
1666         break;
1667     case SVt_PVHV: {
1668         U32 usedkeys;
1669         if (SvOOK(sv)) {
1670             struct xpvhv_aux *const aux = HvAUX(sv);
1671             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %"UVuf"\n",
1672                              (UV)aux->xhv_aux_flags);
1673         }
1674         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1675         usedkeys = HvUSEDKEYS(sv);
1676         if (HvARRAY(sv) && usedkeys) {
1677             /* Show distribution of HEs in the ARRAY */
1678             int freq[200];
1679 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1680             int i;
1681             int max = 0;
1682             U32 pow2 = 2, keys = usedkeys;
1683             NV theoret, sum = 0;
1684
1685             PerlIO_printf(file, "  (");
1686             Zero(freq, FREQ_MAX + 1, int);
1687             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1688                 HE* h;
1689                 int count = 0;
1690                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1691                     count++;
1692                 if (count > FREQ_MAX)
1693                     count = FREQ_MAX;
1694                 freq[count]++;
1695                 if (max < count)
1696                     max = count;
1697             }
1698             for (i = 0; i <= max; i++) {
1699                 if (freq[i]) {
1700                     PerlIO_printf(file, "%d%s:%d", i,
1701                                   (i == FREQ_MAX) ? "+" : "",
1702                                   freq[i]);
1703                     if (i != max)
1704                         PerlIO_printf(file, ", ");
1705                 }
1706             }
1707             PerlIO_putc(file, ')');
1708             /* The "quality" of a hash is defined as the total number of
1709                comparisons needed to access every element once, relative
1710                to the expected number needed for a random hash.
1711
1712                The total number of comparisons is equal to the sum of
1713                the squares of the number of entries in each bucket.
1714                For a random hash of n keys into k buckets, the expected
1715                value is
1716                                 n + n(n-1)/2k
1717             */
1718
1719             for (i = max; i > 0; i--) { /* Precision: count down. */
1720                 sum += freq[i] * i * i;
1721             }
1722             while ((keys = keys >> 1))
1723                 pow2 = pow2 << 1;
1724             theoret = usedkeys;
1725             theoret += theoret * (theoret-1)/pow2;
1726             PerlIO_putc(file, '\n');
1727             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1728         }
1729         PerlIO_putc(file, '\n');
1730         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)usedkeys);
1731         {
1732             STRLEN count = 0;
1733             HE **ents = HvARRAY(sv);
1734
1735             if (ents) {
1736                 HE *const *const last = ents + HvMAX(sv);
1737                 count = last + 1 - ents;
1738                 
1739                 do {
1740                     if (!*ents)
1741                         --count;
1742                 } while (++ents <= last);
1743             }
1744
1745             if (SvOOK(sv)) {
1746                 struct xpvhv_aux *const aux = HvAUX(sv);
1747                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf
1748                                  " (cached = %"UVuf")\n",
1749                                  (UV)count, (UV)aux->xhv_fill_lazy);
1750             } else {
1751                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
1752                                  (UV)count);
1753             }
1754         }
1755         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1756         if (SvOOK(sv)) {
1757             Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1758             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1759 #ifdef PERL_HASH_RANDOMIZE_KEYS
1760             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1761             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1762                 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1763             }
1764 #endif
1765             PerlIO_putc(file, '\n');
1766         }
1767         {
1768             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1769             if (mg && mg->mg_obj) {
1770                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1771             }
1772         }
1773         {
1774             const char * const hvname = HvNAME_get(sv);
1775             if (hvname) {
1776           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1777      Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1778                                        generic_pv_escape( tmpsv, hvname,
1779                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
1780         }
1781         }
1782         if (SvOOK(sv)) {
1783             AV * const backrefs
1784                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1785             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1786             if (HvAUX(sv)->xhv_name_count)
1787                 Perl_dump_indent(aTHX_
1788                  level, file, "  NAMECOUNT = %"IVdf"\n",
1789                  (IV)HvAUX(sv)->xhv_name_count
1790                 );
1791             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1792                 const I32 count = HvAUX(sv)->xhv_name_count;
1793                 if (count) {
1794                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1795                     /* The starting point is the first element if count is
1796                        positive and the second element if count is negative. */
1797                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1798                         + (count < 0 ? 1 : 0);
1799                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1800                         + (count < 0 ? -count : count);
1801                     while (hekp < endp) {
1802                         if (HEK_LEN(*hekp)) {
1803              SV *tmp = newSVpvs_flags("", SVs_TEMP);
1804                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1805                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1806                         } else {
1807                             /* This should never happen. */
1808                             sv_catpvs(names, ", (null)");
1809                         }
1810                         ++hekp;
1811                     }
1812                     Perl_dump_indent(aTHX_
1813                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1814                     );
1815                 }
1816                 else {
1817                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1818                     const char *const hvename = HvENAME_get(sv);
1819                     Perl_dump_indent(aTHX_
1820                      level, file, "  ENAME = \"%s\"\n",
1821                      generic_pv_escape(tmp, hvename,
1822                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1823                 }
1824             }
1825             if (backrefs) {
1826                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1827                                  PTR2UV(backrefs));
1828                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1829                            dumpops, pvlim);
1830             }
1831             if (meta) {
1832                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1833                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1834                                  generic_pv_escape( tmpsv, meta->mro_which->name,
1835                                 meta->mro_which->length,
1836                                 (meta->mro_which->kflags & HVhek_UTF8)),
1837                                  PTR2UV(meta->mro_which));
1838                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1839                                  (UV)meta->cache_gen);
1840                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1841                                  (UV)meta->pkg_gen);
1842                 if (meta->mro_linear_all) {
1843                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1844                                  PTR2UV(meta->mro_linear_all));
1845                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1846                            dumpops, pvlim);
1847                 }
1848                 if (meta->mro_linear_current) {
1849                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1850                                  PTR2UV(meta->mro_linear_current));
1851                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1852                            dumpops, pvlim);
1853                 }
1854                 if (meta->mro_nextmethod) {
1855                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1856                                  PTR2UV(meta->mro_nextmethod));
1857                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1858                            dumpops, pvlim);
1859                 }
1860                 if (meta->isa) {
1861                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1862                                  PTR2UV(meta->isa));
1863                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1864                            dumpops, pvlim);
1865                 }
1866             }
1867         }
1868         if (nest < maxnest) {
1869             HV * const hv = MUTABLE_HV(sv);
1870             STRLEN i;
1871             HE *he;
1872
1873             if (HvARRAY(hv)) {
1874                 int count = maxnest - nest;
1875                 for (i=0; i <= HvMAX(hv); i++) {
1876                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1877                         U32 hash;
1878                         SV * keysv;
1879                         const char * keypv;
1880                         SV * elt;
1881                         STRLEN len;
1882
1883                         if (count-- <= 0) goto DONEHV;
1884
1885                         hash = HeHASH(he);
1886                         keysv = hv_iterkeysv(he);
1887                         keypv = SvPV_const(keysv, len);
1888                         elt = HeVAL(he);
1889
1890                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1891                         if (SvUTF8(keysv))
1892                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1893                         if (HvEITER_get(hv) == he)
1894                             PerlIO_printf(file, "[CURRENT] ");
1895                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1896                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1897                     }
1898                 }
1899               DONEHV:;
1900             }
1901         }
1902         break;
1903     } /* case SVt_PVHV */
1904
1905     case SVt_PVCV:
1906         if (CvAUTOLOAD(sv)) {
1907             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1908        STRLEN len;
1909             const char *const name =  SvPV_const(sv, len);
1910             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
1911                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1912         }
1913         if (SvPOK(sv)) {
1914        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1915        const char *const proto = CvPROTO(sv);
1916             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
1917                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1918                                 SvUTF8(sv)));
1919         }
1920         /* FALLTHROUGH */
1921     case SVt_PVFM:
1922         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1923         if (!CvISXSUB(sv)) {
1924             if (CvSTART(sv)) {
1925                 Perl_dump_indent(aTHX_ level, file,
1926                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1927                                  PTR2UV(CvSTART(sv)),
1928                                  (IV)sequence_num(CvSTART(sv)));
1929             }
1930             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1931                              PTR2UV(CvROOT(sv)));
1932             if (CvROOT(sv) && dumpops) {
1933                 do_op_dump(level+1, file, CvROOT(sv));
1934             }
1935         } else {
1936             SV * const constant = cv_const_sv((const CV *)sv);
1937
1938             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1939
1940             if (constant) {
1941                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1942                                  " (CONST SV)\n",
1943                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1944                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1945                            pvlim);
1946             } else {
1947                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1948                                  (IV)CvXSUBANY(sv).any_i32);
1949             }
1950         }
1951         if (CvNAMED(sv))
1952             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1953                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
1954         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1955         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1956         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1957         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1958         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1959         if (!CvISXSUB(sv)) {
1960             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1961             if (nest < maxnest) {
1962                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1963             }
1964         }
1965         else
1966             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
1967         {
1968             const CV * const outside = CvOUTSIDE(sv);
1969             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1970                         PTR2UV(outside),
1971                         (!outside ? "null"
1972                          : CvANON(outside) ? "ANON"
1973                          : (outside == PL_main_cv) ? "MAIN"
1974                          : CvUNIQUE(outside) ? "UNIQUE"
1975                          : CvGV(outside) ?
1976                              generic_pv_escape(
1977                                  newSVpvs_flags("", SVs_TEMP),
1978                                  GvNAME(CvGV(outside)),
1979                                  GvNAMELEN(CvGV(outside)),
1980                                  GvNAMEUTF8(CvGV(outside)))
1981                          : "UNDEFINED"));
1982         }
1983         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1984             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1985         break;
1986
1987     case SVt_PVGV:
1988     case SVt_PVLV:
1989         if (type == SVt_PVLV) {
1990             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
1991             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1992             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1993             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1994             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
1995             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
1996                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1997                     dumpops, pvlim);
1998         }
1999         if (isREGEXP(sv)) goto dumpregexp;
2000         if (!isGV_with_GP(sv))
2001             break;
2002        {
2003           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2004           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2005                     generic_pv_escape(tmpsv, GvNAME(sv),
2006                                       GvNAMELEN(sv),
2007                                       GvNAMEUTF8(sv)));
2008        }
2009         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2010         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2011         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2012         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2013         if (!GvGP(sv))
2014             break;
2015         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2016         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2017         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2018         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2019         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2020         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2021         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2022         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2023         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%"UVxf
2024                                             " (%s)\n",
2025                                (UV)GvGPFLAGS(sv),
2026                                GvALIASED_SV(sv) ? "ALIASED_SV" : "");
2027         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2028         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2029         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2030         break;
2031     case SVt_PVIO:
2032         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2033         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2034         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2035         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2036         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2037         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2038         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2039         if (IoTOP_NAME(sv))
2040             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2041         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2042             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2043         else {
2044             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2045                              PTR2UV(IoTOP_GV(sv)));
2046             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2047                         maxnest, dumpops, pvlim);
2048         }
2049         /* Source filters hide things that are not GVs in these three, so let's
2050            be careful out there.  */
2051         if (IoFMT_NAME(sv))
2052             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2053         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2054             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2055         else {
2056             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2057                              PTR2UV(IoFMT_GV(sv)));
2058             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2059                         maxnest, dumpops, pvlim);
2060         }
2061         if (IoBOTTOM_NAME(sv))
2062             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2063         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2064             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2065         else {
2066             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2067                              PTR2UV(IoBOTTOM_GV(sv)));
2068             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2069                         maxnest, dumpops, pvlim);
2070         }
2071         if (isPRINT(IoTYPE(sv)))
2072             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2073         else
2074             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2075         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2076         break;
2077     case SVt_REGEXP:
2078       dumpregexp:
2079         {
2080             struct regexp * const r = ReANY((REGEXP*)sv);
2081
2082 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2083             sv_setpv(d,"");                                 \
2084             append_flags(d, flags, names);     \
2085             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2086                 SvCUR_set(d, SvCUR(d) - 1);                 \
2087                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2088             }                                               \
2089 } STMT_END
2090             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2091             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
2092                                 (UV)(r->compflags), SvPVX_const(d));
2093
2094             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2095             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2096                                 (UV)(r->extflags), SvPVX_const(d));
2097
2098             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf" (%s)\n",
2099                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2100             if (r->engine == &PL_core_reg_engine) {
2101                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2102                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf" (%s)\n",
2103                                 (UV)(r->intflags), SvPVX_const(d));
2104             } else {
2105                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2106                                 (UV)(r->intflags));
2107             }
2108 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2109             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2110                                 (UV)(r->nparens));
2111             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2112                                 (UV)(r->lastparen));
2113             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2114                                 (UV)(r->lastcloseparen));
2115             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2116                                 (IV)(r->minlen));
2117             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2118                                 (IV)(r->minlenret));
2119             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2120                                 (UV)(r->gofs));
2121             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2122                                 (UV)(r->pre_prefix));
2123             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2124                                 (IV)(r->sublen));
2125             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
2126                                 (IV)(r->suboffset));
2127             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
2128                                 (IV)(r->subcoffset));
2129             if (r->subbeg)
2130                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2131                             PTR2UV(r->subbeg),
2132                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2133             else
2134                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2135             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2136                                 PTR2UV(r->mother_re));
2137             if (nest < maxnest && r->mother_re)
2138                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2139                            maxnest, dumpops, pvlim);
2140             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2141                                 PTR2UV(r->paren_names));
2142             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2143                                 PTR2UV(r->substrs));
2144             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2145                                 PTR2UV(r->pprivate));
2146             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2147                                 PTR2UV(r->offs));
2148             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2149                                 PTR2UV(r->qr_anoncv));
2150 #ifdef PERL_ANY_COW
2151             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2152                                 PTR2UV(r->saved_copy));
2153 #endif
2154         }
2155         break;
2156     }
2157     SvREFCNT_dec_NN(d);
2158 }
2159
2160 /*
2161 =for apidoc sv_dump
2162
2163 Dumps the contents of an SV to the C<STDERR> filehandle.
2164
2165 For an example of its output, see L<Devel::Peek>.
2166
2167 =cut
2168 */
2169
2170 void
2171 Perl_sv_dump(pTHX_ SV *sv)
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     if (!PL_op) {
2185         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2186         return 0;
2187     }
2188
2189     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2190     do {
2191 #ifdef PERL_TRACE_OPS
2192         ++PL_op_exec_cnt[PL_op->op_type];
2193 #endif
2194         if (PL_debug) {
2195             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2196                 PerlIO_printf(Perl_debug_log,
2197                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2198                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2199                               PTR2UV(*PL_watchaddr));
2200             if (DEBUG_s_TEST_) {
2201                 if (DEBUG_v_TEST_) {
2202                     PerlIO_printf(Perl_debug_log, "\n");
2203                     deb_stack_all();
2204                 }
2205                 else
2206                     debstack();
2207             }
2208
2209
2210             if (DEBUG_t_TEST_) debop(PL_op);
2211             if (DEBUG_P_TEST_) debprof(PL_op);
2212         }
2213
2214         OP_ENTRY_PROBE(OP_NAME(PL_op));
2215     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2216     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2217     PERL_ASYNC_CHECK();
2218
2219     TAINT_NOT;
2220     return 0;
2221 }
2222
2223 I32
2224 Perl_debop(pTHX_ const OP *o)
2225 {
2226     int count;
2227
2228     PERL_ARGS_ASSERT_DEBOP;
2229
2230     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2231         return 0;
2232
2233     Perl_deb(aTHX_ "%s", OP_NAME(o));
2234     switch (o->op_type) {
2235     case OP_CONST:
2236     case OP_HINTSEVAL:
2237         /* With ITHREADS, consts are stored in the pad, and the right pad
2238          * may not be active here, so check.
2239          * Looks like only during compiling the pads are illegal.
2240          */
2241 #ifdef USE_ITHREADS
2242         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2243 #endif
2244             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2245         break;
2246     case OP_GVSV:
2247     case OP_GV:
2248         if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2249             SV * const sv = newSV(0);
2250             gv_fullname3(sv, cGVOPo_gv, NULL);
2251             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2252             SvREFCNT_dec_NN(sv);
2253         }
2254         else if (cGVOPo_gv) {
2255             SV * const sv = newSV(0);
2256             assert(SvROK(cGVOPo_gv));
2257             assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2258             PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2259                     SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2260             SvREFCNT_dec_NN(sv);
2261         }
2262         else
2263             PerlIO_printf(Perl_debug_log, "(NULL)");
2264         break;
2265
2266     case OP_PADSV:
2267     case OP_PADAV:
2268     case OP_PADHV:
2269         count = 1;
2270         goto dump_padop;
2271     case OP_PADRANGE:
2272         count = o->op_private & OPpPADRANGE_COUNTMASK;
2273     dump_padop:
2274         /* print the lexical's name */
2275         {
2276             CV * const cv = deb_curcv(cxstack_ix);
2277             PADNAME *sv;
2278             PADNAMELIST * comppad = NULL;
2279             int i;
2280
2281             if (cv) {
2282                 PADLIST * const padlist = CvPADLIST(cv);
2283                 comppad = PadlistNAMES(padlist);
2284             }
2285             PerlIO_printf(Perl_debug_log, "(");
2286             for (i = 0; i < count; i++) {
2287                 if (comppad &&
2288                         (sv = padnamelist_fetch(comppad, o->op_targ + i)))
2289                     PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2290                 else
2291                     PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2292                             (UV)o->op_targ+i);
2293                 if (i < count-1)
2294                     PerlIO_printf(Perl_debug_log, ",");
2295             }
2296             PerlIO_printf(Perl_debug_log, ")");
2297         }
2298         break;
2299
2300     default:
2301         break;
2302     }
2303     PerlIO_printf(Perl_debug_log, "\n");
2304     return 0;
2305 }
2306
2307 STATIC CV*
2308 S_deb_curcv(pTHX_ const I32 ix)
2309 {
2310     const PERL_CONTEXT * const cx = &cxstack[ix];
2311     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2312         return cx->blk_sub.cv;
2313     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2314         return cx->blk_eval.cv;
2315     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2316         return PL_main_cv;
2317     else if (ix <= 0)
2318         return NULL;
2319     else
2320         return deb_curcv(ix - 1);
2321 }
2322
2323 void
2324 Perl_watch(pTHX_ char **addr)
2325 {
2326     PERL_ARGS_ASSERT_WATCH;
2327
2328     PL_watchaddr = addr;
2329     PL_watchok = *addr;
2330     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2331         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2332 }
2333
2334 STATIC void
2335 S_debprof(pTHX_ const OP *o)
2336 {
2337     PERL_ARGS_ASSERT_DEBPROF;
2338
2339     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2340         return;
2341     if (!PL_profiledata)
2342         Newxz(PL_profiledata, MAXO, U32);
2343     ++PL_profiledata[o->op_type];
2344 }
2345
2346 void
2347 Perl_debprofdump(pTHX)
2348 {
2349     unsigned i;
2350     if (!PL_profiledata)
2351         return;
2352     for (i = 0; i < MAXO; i++) {
2353         if (PL_profiledata[i])
2354             PerlIO_printf(Perl_debug_log,
2355                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2356                                        PL_op_name[i]);
2357     }
2358 }
2359
2360
2361 /*
2362  * Local variables:
2363  * c-indentation-style: bsd
2364  * c-basic-offset: 4
2365  * indent-tabs-mode: nil
2366  * End:
2367  *
2368  * ex: set ts=8 sts=4 sw=4 et:
2369  */