Opcode.pm: wrap long verbatim pod line
[perl.git] / dump.c
1 /*    dump.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *  'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13  *   it has not been hard for me to read your mind and memory.'
14  *
15  *     [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
16  */
17
18 /* This file contains utility routines to dump the contents of SV and OP
19  * structures, as used by command-line options like -Dt and -Dx, and
20  * by Devel::Peek.
21  *
22  * It also holds the debugging version of the  runops function.
23
24 =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 & SVpad_NAME) == SVpad_NAME
1435           && (type == SVt_PVMG || type == SVt_PVNV))) {
1436         if ((flags & SVs_PADSTALE))
1437             sv_catpv(d, "PADSTALE,");
1438     }
1439     if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1440         if ((flags & SVs_PADTMP))
1441             sv_catpv(d, "PADTMP,");
1442     }
1443     append_flags(d, flags, first_sv_flags_names);
1444     if (flags & SVf_ROK)  {     
1445                                 sv_catpv(d, "ROK,");
1446         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1447     }
1448     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1449     append_flags(d, flags, second_sv_flags_names);
1450     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1451                            && type != SVt_PVAV) {
1452         if (SvPCS_IMPORTED(sv))
1453                                 sv_catpv(d, "PCS_IMPORTED,");
1454         else
1455                                 sv_catpv(d, "SCREAM,");
1456     }
1457
1458     /* process type-specific SV flags */
1459
1460     switch (type) {
1461     case SVt_PVCV:
1462     case SVt_PVFM:
1463         append_flags(d, CvFLAGS(sv), cv_flags_names);
1464         break;
1465     case SVt_PVHV:
1466         append_flags(d, flags, hv_flags_names);
1467         break;
1468     case SVt_PVGV:
1469     case SVt_PVLV:
1470         if (isGV_with_GP(sv)) {
1471             append_flags(d, GvFLAGS(sv), gp_flags_names);
1472         }
1473         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1474             sv_catpv(d, "IMPORT");
1475             if (GvIMPORTED(sv) == GVf_IMPORTED)
1476                 sv_catpv(d, "ALL,");
1477             else {
1478                 sv_catpv(d, "(");
1479                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1480                 sv_catpv(d, " ),");
1481             }
1482         }
1483         /* FALLTHROUGH */
1484     default:
1485     evaled_or_uv:
1486         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1487         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1488         break;
1489     case SVt_PVMG:
1490         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1491         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1492         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1493         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1494         /* FALLTHROUGH */
1495     case SVt_PVNV:
1496         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1497         goto evaled_or_uv;
1498     case SVt_PVAV:
1499         if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
1500         break;
1501     }
1502     /* SVphv_SHAREKEYS is also 0x20000000 */
1503     if ((type != SVt_PVHV) && SvUTF8(sv))
1504         sv_catpv(d, "UTF8");
1505
1506     if (*(SvEND(d) - 1) == ',') {
1507         SvCUR_set(d, SvCUR(d) - 1);
1508         SvPVX(d)[SvCUR(d)] = '\0';
1509     }
1510     sv_catpv(d, ")");
1511     s = SvPVX_const(d);
1512
1513     /* dump initial SV details */
1514
1515 #ifdef DEBUG_LEAKING_SCALARS
1516     Perl_dump_indent(aTHX_ level, file,
1517         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1518         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1519         sv->sv_debug_line,
1520         sv->sv_debug_inpad ? "for" : "by",
1521         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1522         PTR2UV(sv->sv_debug_parent),
1523         sv->sv_debug_serial
1524     );
1525 #endif
1526     Perl_dump_indent(aTHX_ level, file, "SV = ");
1527
1528     /* Dump SV type */
1529
1530     if (type < SVt_LAST) {
1531         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1532
1533         if (type ==  SVt_NULL) {
1534             SvREFCNT_dec_NN(d);
1535             return;
1536         }
1537     } else {
1538         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1539         SvREFCNT_dec_NN(d);
1540         return;
1541     }
1542
1543     /* Dump general SV fields */
1544
1545     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1546          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1547          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1548         || (type == SVt_IV && !SvROK(sv))) {
1549         if (SvIsUV(sv)
1550 #ifdef PERL_OLD_COPY_ON_WRITE
1551                        || SvIsCOW(sv)
1552 #endif
1553                                      )
1554             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1555         else
1556             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1557 #ifdef PERL_OLD_COPY_ON_WRITE
1558         if (SvIsCOW_shared_hash(sv))
1559             PerlIO_printf(file, "  (HASH)");
1560         else if (SvIsCOW_normal(sv))
1561             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1562 #endif
1563         PerlIO_putc(file, '\n');
1564     }
1565
1566     if ((type == SVt_PVNV || type == SVt_PVMG)
1567         && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1568         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1569                          (UV) COP_SEQ_RANGE_LOW(sv));
1570         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1571                          (UV) COP_SEQ_RANGE_HIGH(sv));
1572     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1573                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1574                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1575                || type == SVt_NV) {
1576         STORE_NUMERIC_LOCAL_SET_STANDARD();
1577         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1578         RESTORE_NUMERIC_LOCAL();
1579     }
1580
1581     if (SvROK(sv)) {
1582         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1583         if (nest < maxnest)
1584             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1585     }
1586
1587     if (type < SVt_PV) {
1588         SvREFCNT_dec_NN(d);
1589         return;
1590     }
1591
1592     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1593      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1594         const bool re = isREGEXP(sv);
1595         const char * const ptr =
1596             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1597         if (ptr) {
1598             STRLEN delta;
1599             if (SvOOK(sv)) {
1600                 SvOOK_offset(sv, delta);
1601                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1602                                  (UV) delta);
1603             } else {
1604                 delta = 0;
1605             }
1606             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(ptr));
1607             if (SvOOK(sv)) {
1608                 PerlIO_printf(file, "( %s . ) ",
1609                               pv_display(d, ptr - delta, delta, 0,
1610                                          pvlim));
1611             }
1612             if (type == SVt_INVLIST) {
1613                 PerlIO_printf(file, "\n");
1614                 /* 4 blanks indents 2 beyond the PV, etc */
1615                 _invlist_dump(file, level, "    ", sv);
1616             }
1617             else {
1618                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1619                                                      re ? 0 : SvLEN(sv),
1620                                                      pvlim));
1621                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1622                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1623                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1624                                                         UNI_DISPLAY_QQ));
1625                 PerlIO_printf(file, "\n");
1626             }
1627             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1628             if (!re)
1629                 Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
1630                                        (IV)SvLEN(sv));
1631 #ifdef PERL_NEW_COPY_ON_WRITE
1632             if (SvIsCOW(sv) && SvLEN(sv))
1633                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1634                                        CowREFCNT(sv));
1635 #endif
1636         }
1637         else
1638             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1639     }
1640
1641     if (type >= SVt_PVMG) {
1642         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1643             HV * const ost = SvOURSTASH(sv);
1644             if (ost)
1645                 do_hv_dump(level, file, "  OURSTASH", ost);
1646         } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1647             Perl_dump_indent(aTHX_ level, file, "  MAXNAMED = %"UVuf"\n",
1648                                    (UV)PadnamelistMAXNAMED(sv));
1649         } else {
1650             if (SvMAGIC(sv))
1651                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1652         }
1653         if (SvSTASH(sv))
1654             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1655
1656         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1657             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1658         }
1659     }
1660
1661     /* Dump type-specific SV fields */
1662
1663     switch (type) {
1664     case SVt_PVAV:
1665         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1666         if (AvARRAY(sv) != AvALLOC(sv)) {
1667             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1668             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1669         }
1670         else
1671             PerlIO_putc(file, '\n');
1672         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1673         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1674         /* arylen is stored in magic, and padnamelists use SvMAGIC for
1675            something else. */
1676         if (!AvPAD_NAMELIST(sv))
1677             Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n",
1678                                    SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1679         sv_setpvs(d, "");
1680         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1681         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1682         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1683                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1684         if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1685             SSize_t count;
1686             for (count = 0; count <=  av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1687                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1688
1689                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1690                 if (elt)
1691                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1692             }
1693         }
1694         break;
1695     case SVt_PVHV: {
1696         U32 usedkeys;
1697         if (SvOOK(sv)) {
1698             struct xpvhv_aux *const aux = HvAUX(sv);
1699             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %"UVuf"\n",
1700                              (UV)aux->xhv_aux_flags);
1701         }
1702         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1703         usedkeys = HvUSEDKEYS(sv);
1704         if (HvARRAY(sv) && usedkeys) {
1705             /* Show distribution of HEs in the ARRAY */
1706             int freq[200];
1707 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1708             int i;
1709             int max = 0;
1710             U32 pow2 = 2, keys = usedkeys;
1711             NV theoret, sum = 0;
1712
1713             PerlIO_printf(file, "  (");
1714             Zero(freq, FREQ_MAX + 1, int);
1715             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1716                 HE* h;
1717                 int count = 0;
1718                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1719                     count++;
1720                 if (count > FREQ_MAX)
1721                     count = FREQ_MAX;
1722                 freq[count]++;
1723                 if (max < count)
1724                     max = count;
1725             }
1726             for (i = 0; i <= max; i++) {
1727                 if (freq[i]) {
1728                     PerlIO_printf(file, "%d%s:%d", i,
1729                                   (i == FREQ_MAX) ? "+" : "",
1730                                   freq[i]);
1731                     if (i != max)
1732                         PerlIO_printf(file, ", ");
1733                 }
1734             }
1735             PerlIO_putc(file, ')');
1736             /* The "quality" of a hash is defined as the total number of
1737                comparisons needed to access every element once, relative
1738                to the expected number needed for a random hash.
1739
1740                The total number of comparisons is equal to the sum of
1741                the squares of the number of entries in each bucket.
1742                For a random hash of n keys into k buckets, the expected
1743                value is
1744                                 n + n(n-1)/2k
1745             */
1746
1747             for (i = max; i > 0; i--) { /* Precision: count down. */
1748                 sum += freq[i] * i * i;
1749             }
1750             while ((keys = keys >> 1))
1751                 pow2 = pow2 << 1;
1752             theoret = usedkeys;
1753             theoret += theoret * (theoret-1)/pow2;
1754             PerlIO_putc(file, '\n');
1755             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1756         }
1757         PerlIO_putc(file, '\n');
1758         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)usedkeys);
1759         {
1760             STRLEN count = 0;
1761             HE **ents = HvARRAY(sv);
1762
1763             if (ents) {
1764                 HE *const *const last = ents + HvMAX(sv);
1765                 count = last + 1 - ents;
1766                 
1767                 do {
1768                     if (!*ents)
1769                         --count;
1770                 } while (++ents <= last);
1771             }
1772
1773             if (SvOOK(sv)) {
1774                 struct xpvhv_aux *const aux = HvAUX(sv);
1775                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf
1776                                  " (cached = %"UVuf")\n",
1777                                  (UV)count, (UV)aux->xhv_fill_lazy);
1778             } else {
1779                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
1780                                  (UV)count);
1781             }
1782         }
1783         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1784         if (SvOOK(sv)) {
1785             Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1786             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1787 #ifdef PERL_HASH_RANDOMIZE_KEYS
1788             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1789             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1790                 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1791             }
1792 #endif
1793             PerlIO_putc(file, '\n');
1794         }
1795         {
1796             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1797             if (mg && mg->mg_obj) {
1798                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1799             }
1800         }
1801         {
1802             const char * const hvname = HvNAME_get(sv);
1803             if (hvname) {
1804           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1805      Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1806                                        generic_pv_escape( tmpsv, hvname,
1807                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
1808         }
1809         }
1810         if (SvOOK(sv)) {
1811             AV * const backrefs
1812                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1813             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1814             if (HvAUX(sv)->xhv_name_count)
1815                 Perl_dump_indent(aTHX_
1816                  level, file, "  NAMECOUNT = %"IVdf"\n",
1817                  (IV)HvAUX(sv)->xhv_name_count
1818                 );
1819             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1820                 const I32 count = HvAUX(sv)->xhv_name_count;
1821                 if (count) {
1822                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1823                     /* The starting point is the first element if count is
1824                        positive and the second element if count is negative. */
1825                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1826                         + (count < 0 ? 1 : 0);
1827                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1828                         + (count < 0 ? -count : count);
1829                     while (hekp < endp) {
1830                         if (HEK_LEN(*hekp)) {
1831              SV *tmp = newSVpvs_flags("", SVs_TEMP);
1832                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1833                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1834                         } else {
1835                             /* This should never happen. */
1836                             sv_catpvs(names, ", (null)");
1837                         }
1838                         ++hekp;
1839                     }
1840                     Perl_dump_indent(aTHX_
1841                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1842                     );
1843                 }
1844                 else {
1845                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1846                     const char *const hvename = HvENAME_get(sv);
1847                     Perl_dump_indent(aTHX_
1848                      level, file, "  ENAME = \"%s\"\n",
1849                      generic_pv_escape(tmp, hvename,
1850                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1851                 }
1852             }
1853             if (backrefs) {
1854                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1855                                  PTR2UV(backrefs));
1856                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1857                            dumpops, pvlim);
1858             }
1859             if (meta) {
1860                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1861                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1862                                  generic_pv_escape( tmpsv, meta->mro_which->name,
1863                                 meta->mro_which->length,
1864                                 (meta->mro_which->kflags & HVhek_UTF8)),
1865                                  PTR2UV(meta->mro_which));
1866                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1867                                  (UV)meta->cache_gen);
1868                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1869                                  (UV)meta->pkg_gen);
1870                 if (meta->mro_linear_all) {
1871                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1872                                  PTR2UV(meta->mro_linear_all));
1873                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1874                            dumpops, pvlim);
1875                 }
1876                 if (meta->mro_linear_current) {
1877                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1878                                  PTR2UV(meta->mro_linear_current));
1879                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1880                            dumpops, pvlim);
1881                 }
1882                 if (meta->mro_nextmethod) {
1883                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1884                                  PTR2UV(meta->mro_nextmethod));
1885                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1886                            dumpops, pvlim);
1887                 }
1888                 if (meta->isa) {
1889                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1890                                  PTR2UV(meta->isa));
1891                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1892                            dumpops, pvlim);
1893                 }
1894             }
1895         }
1896         if (nest < maxnest) {
1897             HV * const hv = MUTABLE_HV(sv);
1898             STRLEN i;
1899             HE *he;
1900
1901             if (HvARRAY(hv)) {
1902                 int count = maxnest - nest;
1903                 for (i=0; i <= HvMAX(hv); i++) {
1904                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1905                         U32 hash;
1906                         SV * keysv;
1907                         const char * keypv;
1908                         SV * elt;
1909                         STRLEN len;
1910
1911                         if (count-- <= 0) goto DONEHV;
1912
1913                         hash = HeHASH(he);
1914                         keysv = hv_iterkeysv(he);
1915                         keypv = SvPV_const(keysv, len);
1916                         elt = HeVAL(he);
1917
1918                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1919                         if (SvUTF8(keysv))
1920                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1921                         if (HvEITER_get(hv) == he)
1922                             PerlIO_printf(file, "[CURRENT] ");
1923                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1924                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1925                     }
1926                 }
1927               DONEHV:;
1928             }
1929         }
1930         break;
1931     } /* case SVt_PVHV */
1932
1933     case SVt_PVCV:
1934         if (CvAUTOLOAD(sv)) {
1935             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1936        STRLEN len;
1937             const char *const name =  SvPV_const(sv, len);
1938             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
1939                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1940         }
1941         if (SvPOK(sv)) {
1942        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1943        const char *const proto = CvPROTO(sv);
1944             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
1945                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1946                                 SvUTF8(sv)));
1947         }
1948         /* FALLTHROUGH */
1949     case SVt_PVFM:
1950         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1951         if (!CvISXSUB(sv)) {
1952             if (CvSTART(sv)) {
1953                 Perl_dump_indent(aTHX_ level, file,
1954                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1955                                  PTR2UV(CvSTART(sv)),
1956                                  (IV)sequence_num(CvSTART(sv)));
1957             }
1958             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1959                              PTR2UV(CvROOT(sv)));
1960             if (CvROOT(sv) && dumpops) {
1961                 do_op_dump(level+1, file, CvROOT(sv));
1962             }
1963         } else {
1964             SV * const constant = cv_const_sv((const CV *)sv);
1965
1966             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1967
1968             if (constant) {
1969                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1970                                  " (CONST SV)\n",
1971                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1972                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1973                            pvlim);
1974             } else {
1975                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1976                                  (IV)CvXSUBANY(sv).any_i32);
1977             }
1978         }
1979         if (CvNAMED(sv))
1980             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1981                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
1982         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1983         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1984         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1985         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1986         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1987         if (!CvISXSUB(sv)) {
1988             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1989             if (nest < maxnest) {
1990                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1991             }
1992         }
1993         else
1994             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
1995         {
1996             const CV * const outside = CvOUTSIDE(sv);
1997             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1998                         PTR2UV(outside),
1999                         (!outside ? "null"
2000                          : CvANON(outside) ? "ANON"
2001                          : (outside == PL_main_cv) ? "MAIN"
2002                          : CvUNIQUE(outside) ? "UNIQUE"
2003                          : CvGV(outside) ?
2004                              generic_pv_escape(
2005                                  newSVpvs_flags("", SVs_TEMP),
2006                                  GvNAME(CvGV(outside)),
2007                                  GvNAMELEN(CvGV(outside)),
2008                                  GvNAMEUTF8(CvGV(outside)))
2009                          : "UNDEFINED"));
2010         }
2011         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2012             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2013         break;
2014
2015     case SVt_PVGV:
2016     case SVt_PVLV:
2017         if (type == SVt_PVLV) {
2018             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2019             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2020             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2021             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2022             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2023             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2024                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2025                     dumpops, pvlim);
2026         }
2027         if (isREGEXP(sv)) goto dumpregexp;
2028         if (!isGV_with_GP(sv))
2029             break;
2030        {
2031           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2032           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2033                     generic_pv_escape(tmpsv, GvNAME(sv),
2034                                       GvNAMELEN(sv),
2035                                       GvNAMEUTF8(sv)));
2036        }
2037         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2038         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2039         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2040         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2041         if (!GvGP(sv))
2042             break;
2043         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2044         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2045         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2046         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2047         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2048         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2049         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2050         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2051         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%"UVxf
2052                                             " (%s)\n",
2053                                (UV)GvGPFLAGS(sv),
2054                                GvALIASED_SV(sv) ? "ALIASED_SV" : "");
2055         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2056         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2057         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2058         break;
2059     case SVt_PVIO:
2060         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2061         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2062         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2063         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2064         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2065         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2066         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2067         if (IoTOP_NAME(sv))
2068             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2069         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2070             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2071         else {
2072             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2073                              PTR2UV(IoTOP_GV(sv)));
2074             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2075                         maxnest, dumpops, pvlim);
2076         }
2077         /* Source filters hide things that are not GVs in these three, so let's
2078            be careful out there.  */
2079         if (IoFMT_NAME(sv))
2080             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2081         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2082             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2083         else {
2084             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2085                              PTR2UV(IoFMT_GV(sv)));
2086             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2087                         maxnest, dumpops, pvlim);
2088         }
2089         if (IoBOTTOM_NAME(sv))
2090             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2091         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2092             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2093         else {
2094             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2095                              PTR2UV(IoBOTTOM_GV(sv)));
2096             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2097                         maxnest, dumpops, pvlim);
2098         }
2099         if (isPRINT(IoTYPE(sv)))
2100             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2101         else
2102             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2103         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2104         break;
2105     case SVt_REGEXP:
2106       dumpregexp:
2107         {
2108             struct regexp * const r = ReANY((REGEXP*)sv);
2109
2110 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2111             sv_setpv(d,"");                                 \
2112             append_flags(d, flags, names);     \
2113             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2114                 SvCUR_set(d, SvCUR(d) - 1);                 \
2115                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2116             }                                               \
2117 } STMT_END
2118             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2119             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
2120                                 (UV)(r->compflags), SvPVX_const(d));
2121
2122             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2123             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2124                                 (UV)(r->extflags), SvPVX_const(d));
2125
2126             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf" (%s)\n",
2127                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2128             if (r->engine == &PL_core_reg_engine) {
2129                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2130                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf" (%s)\n",
2131                                 (UV)(r->intflags), SvPVX_const(d));
2132             } else {
2133                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2134                                 (UV)(r->intflags));
2135             }
2136 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2137             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2138                                 (UV)(r->nparens));
2139             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2140                                 (UV)(r->lastparen));
2141             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2142                                 (UV)(r->lastcloseparen));
2143             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2144                                 (IV)(r->minlen));
2145             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2146                                 (IV)(r->minlenret));
2147             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2148                                 (UV)(r->gofs));
2149             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2150                                 (UV)(r->pre_prefix));
2151             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2152                                 (IV)(r->sublen));
2153             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
2154                                 (IV)(r->suboffset));
2155             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
2156                                 (IV)(r->subcoffset));
2157             if (r->subbeg)
2158                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2159                             PTR2UV(r->subbeg),
2160                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2161             else
2162                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2163             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2164                                 PTR2UV(r->mother_re));
2165             if (nest < maxnest && r->mother_re)
2166                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2167                            maxnest, dumpops, pvlim);
2168             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2169                                 PTR2UV(r->paren_names));
2170             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2171                                 PTR2UV(r->substrs));
2172             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2173                                 PTR2UV(r->pprivate));
2174             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2175                                 PTR2UV(r->offs));
2176             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2177                                 PTR2UV(r->qr_anoncv));
2178 #ifdef PERL_ANY_COW
2179             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2180                                 PTR2UV(r->saved_copy));
2181 #endif
2182         }
2183         break;
2184     }
2185     SvREFCNT_dec_NN(d);
2186 }
2187
2188 /*
2189 =for apidoc sv_dump
2190
2191 Dumps the contents of an SV to the C<STDERR> filehandle.
2192
2193 For an example of its output, see L<Devel::Peek>.
2194
2195 =cut
2196 */
2197
2198 void
2199 Perl_sv_dump(pTHX_ SV *sv)
2200 {
2201     PERL_ARGS_ASSERT_SV_DUMP;
2202
2203     if (SvROK(sv))
2204         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2205     else
2206         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2207 }
2208
2209 int
2210 Perl_runops_debug(pTHX)
2211 {
2212     if (!PL_op) {
2213         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2214         return 0;
2215     }
2216
2217     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2218     do {
2219 #ifdef PERL_TRACE_OPS
2220         ++PL_op_exec_cnt[PL_op->op_type];
2221 #endif
2222         if (PL_debug) {
2223             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2224                 PerlIO_printf(Perl_debug_log,
2225                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2226                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2227                               PTR2UV(*PL_watchaddr));
2228             if (DEBUG_s_TEST_) {
2229                 if (DEBUG_v_TEST_) {
2230                     PerlIO_printf(Perl_debug_log, "\n");
2231                     deb_stack_all();
2232                 }
2233                 else
2234                     debstack();
2235             }
2236
2237
2238             if (DEBUG_t_TEST_) debop(PL_op);
2239             if (DEBUG_P_TEST_) debprof(PL_op);
2240         }
2241
2242         OP_ENTRY_PROBE(OP_NAME(PL_op));
2243     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2244     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2245     PERL_ASYNC_CHECK();
2246
2247     TAINT_NOT;
2248     return 0;
2249 }
2250
2251 I32
2252 Perl_debop(pTHX_ const OP *o)
2253 {
2254     int count;
2255
2256     PERL_ARGS_ASSERT_DEBOP;
2257
2258     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2259         return 0;
2260
2261     Perl_deb(aTHX_ "%s", OP_NAME(o));
2262     switch (o->op_type) {
2263     case OP_CONST:
2264     case OP_HINTSEVAL:
2265         /* With ITHREADS, consts are stored in the pad, and the right pad
2266          * may not be active here, so check.
2267          * Looks like only during compiling the pads are illegal.
2268          */
2269 #ifdef USE_ITHREADS
2270         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2271 #endif
2272             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2273         break;
2274     case OP_GVSV:
2275     case OP_GV:
2276         if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2277             SV * const sv = newSV(0);
2278             gv_fullname3(sv, cGVOPo_gv, NULL);
2279             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2280             SvREFCNT_dec_NN(sv);
2281         }
2282         else if (cGVOPo_gv) {
2283             SV * const sv = newSV(0);
2284             assert(SvROK(cGVOPo_gv));
2285             assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2286             PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2287                     SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2288             SvREFCNT_dec_NN(sv);
2289         }
2290         else
2291             PerlIO_printf(Perl_debug_log, "(NULL)");
2292         break;
2293
2294     case OP_PADSV:
2295     case OP_PADAV:
2296     case OP_PADHV:
2297         count = 1;
2298         goto dump_padop;
2299     case OP_PADRANGE:
2300         count = o->op_private & OPpPADRANGE_COUNTMASK;
2301     dump_padop:
2302         /* print the lexical's name */
2303         {
2304             CV * const cv = deb_curcv(cxstack_ix);
2305             SV *sv;
2306             PAD * comppad = NULL;
2307             int i;
2308
2309             if (cv) {
2310                 PADLIST * const padlist = CvPADLIST(cv);
2311                 comppad = *PadlistARRAY(padlist);
2312             }
2313             PerlIO_printf(Perl_debug_log, "(");
2314             for (i = 0; i < count; i++) {
2315                 if (comppad &&
2316                         (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2317                     PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2318                 else
2319                     PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2320                             (UV)o->op_targ+i);
2321                 if (i < count-1)
2322                     PerlIO_printf(Perl_debug_log, ",");
2323             }
2324             PerlIO_printf(Perl_debug_log, ")");
2325         }
2326         break;
2327
2328     default:
2329         break;
2330     }
2331     PerlIO_printf(Perl_debug_log, "\n");
2332     return 0;
2333 }
2334
2335 STATIC CV*
2336 S_deb_curcv(pTHX_ const I32 ix)
2337 {
2338     const PERL_CONTEXT * const cx = &cxstack[ix];
2339     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2340         return cx->blk_sub.cv;
2341     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2342         return cx->blk_eval.cv;
2343     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2344         return PL_main_cv;
2345     else if (ix <= 0)
2346         return NULL;
2347     else
2348         return deb_curcv(ix - 1);
2349 }
2350
2351 void
2352 Perl_watch(pTHX_ char **addr)
2353 {
2354     PERL_ARGS_ASSERT_WATCH;
2355
2356     PL_watchaddr = addr;
2357     PL_watchok = *addr;
2358     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2359         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2360 }
2361
2362 STATIC void
2363 S_debprof(pTHX_ const OP *o)
2364 {
2365     PERL_ARGS_ASSERT_DEBPROF;
2366
2367     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2368         return;
2369     if (!PL_profiledata)
2370         Newxz(PL_profiledata, MAXO, U32);
2371     ++PL_profiledata[o->op_type];
2372 }
2373
2374 void
2375 Perl_debprofdump(pTHX)
2376 {
2377     unsigned i;
2378     if (!PL_profiledata)
2379         return;
2380     for (i = 0; i < MAXO; i++) {
2381         if (PL_profiledata[i])
2382             PerlIO_printf(Perl_debug_log,
2383                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2384                                        PL_op_name[i]);
2385     }
2386 }
2387
2388
2389 /*
2390  * Local variables:
2391  * c-indentation-style: bsd
2392  * c-basic-offset: 4
2393  * indent-tabs-mode: nil
2394  * End:
2395  *
2396  * ex: set ts=8 sts=4 sw=4 et:
2397  */