toke.c: Report the proper type for assign ops
[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             if (o->op_targ == OP_NEXTSTATE) {
816                 if (CopLINE(cCOPo))
817                     Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
818                                      (UV)CopLINE(cCOPo));
819         if (CopSTASHPV(cCOPo)) {
820             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
821             HV *stash = CopSTASH(cCOPo);
822             const char * const hvname = HvNAME_get(stash);
823
824                     Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
825                            generic_pv_escape( tmpsv, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash)));
826        }
827      if (CopLABEL(cCOPo)) {
828           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
829           STRLEN label_len;
830           U32 label_flags;
831           const char *label = CopLABEL_len_flags(cCOPo,
832                                                  &label_len,
833                                                  &label_flags);
834                     Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
835                            generic_pv_escape( tmpsv, label, label_len,(label_flags & SVf_UTF8)));
836       }
837
838             }
839         }
840         else
841             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
842     }
843 #ifdef DUMPADDR
844     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
845 #endif
846
847     if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
848         SV * const tmpsv = newSVpvs("");
849         switch (o->op_flags & OPf_WANT) {
850         case OPf_WANT_VOID:
851             sv_catpv(tmpsv, ",VOID");
852             break;
853         case OPf_WANT_SCALAR:
854             sv_catpv(tmpsv, ",SCALAR");
855             break;
856         case OPf_WANT_LIST:
857             sv_catpv(tmpsv, ",LIST");
858             break;
859         default:
860             sv_catpv(tmpsv, ",UNKNOWN");
861             break;
862         }
863         append_flags(tmpsv, o->op_flags, op_flags_names);
864         if (o->op_slabbed)  sv_catpvs(tmpsv, ",SLABBED");
865         if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
866         if (o->op_static)   sv_catpvs(tmpsv, ",STATIC");
867         if (o->op_folded)   sv_catpvs(tmpsv, ",FOLDED");
868         if (o->op_lastsib)  sv_catpvs(tmpsv, ",LASTSIB");
869         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
870                          SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
871     }
872
873     if (o->op_private) {
874         U16 oppriv = o->op_private;
875         I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
876         SV * tmpsv = NULL;
877
878         if (op_ix != -1) {
879             U16 stop = 0;
880             tmpsv = newSVpvs("");
881             for (; !stop; op_ix++) {
882                 U16 entry = PL_op_private_bitdefs[op_ix];
883                 U16 bit = (entry >> 2) & 7;
884                 U16 ix = entry >> 5;
885
886                 stop = (entry & 1);
887
888                 if (entry & 2) {
889                     /* bitfield */
890                     I16 const *p = &PL_op_private_bitfields[ix];
891                     U16 bitmin = (U16) *p++;
892                     I16 label = *p++;
893                     I16 enum_label;
894                     U16 mask = 0;
895                     U16 i;
896                     U16 val;
897
898                     for (i = bitmin; i<= bit; i++)
899                         mask |= (1<<i);
900                     bit = bitmin;
901                     val = (oppriv & mask);
902
903                     if (   label != -1
904                         && PL_op_private_labels[label] == '-'
905                         && PL_op_private_labels[label+1] == '\0'
906                     )
907                         /* display as raw number */
908                         continue;
909
910                     oppriv -= val;
911                     val >>= bit;
912                     enum_label = -1;
913                     while (*p != -1) {
914                         if (val == *p++) {
915                             enum_label = *p;
916                             break;
917                         }
918                         p++;
919                     }
920                     if (val == 0 && enum_label == -1)
921                         /* don't display anonymous zero values */
922                         continue;
923
924                     sv_catpv(tmpsv, ",");
925                     if (label != -1) {
926                         sv_catpv(tmpsv, &PL_op_private_labels[label]);
927                         sv_catpv(tmpsv, "=");
928                     }
929                     sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
930
931                 }
932                 else {
933                     /* bit flag */
934                     if (   oppriv & (1<<bit)
935                         && !(PL_op_private_labels[ix] == '-'
936                              && PL_op_private_labels[ix+1] == '\0'))
937                     {
938                         oppriv -= (1<<bit);
939                         sv_catpv(tmpsv, ",");
940                         sv_catpv(tmpsv, &PL_op_private_labels[ix]);
941                     }
942                 }
943             }
944             if (oppriv) {
945                 sv_catpv(tmpsv, ",");
946                 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
947             }
948         }
949         if (tmpsv && SvCUR(tmpsv)) {
950             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
951         } else
952             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
953                              (UV)oppriv);
954     }
955
956     switch (optype) {
957     case OP_AELEMFAST:
958     case OP_GVSV:
959     case OP_GV:
960 #ifdef USE_ITHREADS
961         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
962 #else
963         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
964             if (cSVOPo->op_sv) {
965       STRLEN len;
966       const char * name;
967       SV * const tmpsv  = newSVpvs_flags("", SVs_TEMP);
968       SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
969                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
970       name = SvPV_const(tmpsv, len);
971                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
972                        generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
973             }
974             else
975                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
976         }
977 #endif
978         break;
979     case OP_CONST:
980     case OP_HINTSEVAL:
981     case OP_METHOD_NAMED:
982 #ifndef USE_ITHREADS
983         /* with ITHREADS, consts are stored in the pad, and the right pad
984          * may not be active here, so skip */
985         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
986 #endif
987         break;
988     case OP_NEXTSTATE:
989     case OP_DBSTATE:
990         if (CopLINE(cCOPo))
991             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
992                              (UV)CopLINE(cCOPo));
993     if (CopSTASHPV(cCOPo)) {
994         SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
995         HV *stash = CopSTASH(cCOPo);
996         const char * const hvname = HvNAME_get(stash);
997         
998             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
999                            generic_pv_escape(tmpsv, hvname,
1000                               HvNAMELEN(stash), HvNAMEUTF8(stash)));
1001     }
1002   if (CopLABEL(cCOPo)) {
1003        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1004        STRLEN label_len;
1005        U32 label_flags;
1006        const char *label = CopLABEL_len_flags(cCOPo,
1007                                                 &label_len, &label_flags);
1008        Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1009                            generic_pv_escape( tmpsv, label, label_len,
1010                                       (label_flags & SVf_UTF8)));
1011    }
1012         break;
1013     case OP_ENTERLOOP:
1014         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1015         if (cLOOPo->op_redoop)
1016             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1017         else
1018             PerlIO_printf(file, "DONE\n");
1019         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1020         if (cLOOPo->op_nextop)
1021             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1022         else
1023             PerlIO_printf(file, "DONE\n");
1024         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1025         if (cLOOPo->op_lastop)
1026             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1027         else
1028             PerlIO_printf(file, "DONE\n");
1029         break;
1030     case OP_COND_EXPR:
1031     case OP_RANGE:
1032     case OP_MAPWHILE:
1033     case OP_GREPWHILE:
1034     case OP_OR:
1035     case OP_AND:
1036         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1037         if (cLOGOPo->op_other)
1038             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1039         else
1040             PerlIO_printf(file, "DONE\n");
1041         break;
1042     case OP_PUSHRE:
1043     case OP_MATCH:
1044     case OP_QR:
1045     case OP_SUBST:
1046         do_pmop_dump(level, file, cPMOPo);
1047         break;
1048     case OP_LEAVE:
1049     case OP_LEAVEEVAL:
1050     case OP_LEAVESUB:
1051     case OP_LEAVESUBLV:
1052     case OP_LEAVEWRITE:
1053     case OP_SCOPE:
1054         if (o->op_private & OPpREFCOUNTED)
1055             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1056         break;
1057     default:
1058         break;
1059     }
1060     if (o->op_flags & OPf_KIDS) {
1061         OP *kid;
1062         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1063             do_op_dump(level, file, kid);
1064     }
1065     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1066 }
1067
1068 /*
1069 =for apidoc op_dump
1070
1071 Dumps the optree starting at OP C<o> to C<STDERR>.
1072
1073 =cut
1074 */
1075
1076 void
1077 Perl_op_dump(pTHX_ const OP *o)
1078 {
1079     PERL_ARGS_ASSERT_OP_DUMP;
1080     do_op_dump(0, Perl_debug_log, o);
1081 }
1082
1083 void
1084 Perl_gv_dump(pTHX_ GV *gv)
1085 {
1086     STRLEN len;
1087     const char* name;
1088     SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1089
1090
1091     PERL_ARGS_ASSERT_GV_DUMP;
1092
1093     if (!gv) {
1094         PerlIO_printf(Perl_debug_log, "{}\n");
1095         return;
1096     }
1097     sv = sv_newmortal();
1098     PerlIO_printf(Perl_debug_log, "{\n");
1099     gv_fullname3(sv, gv, NULL);
1100     name = SvPV_const(sv, len);
1101     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1102                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1103     if (gv != GvEGV(gv)) {
1104         gv_efullname3(sv, GvEGV(gv), NULL);
1105         name = SvPV_const(sv, len);
1106         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1107                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1108     }
1109     PerlIO_putc(Perl_debug_log, '\n');
1110     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1111 }
1112
1113
1114 /* map magic types to the symbolic names
1115  * (with the PERL_MAGIC_ prefixed stripped)
1116  */
1117
1118 static const struct { const char type; const char *name; } magic_names[] = {
1119 #include "mg_names.c"
1120         /* this null string terminates the list */
1121         { 0,                         NULL },
1122 };
1123
1124 void
1125 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1126 {
1127     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1128
1129     for (; mg; mg = mg->mg_moremagic) {
1130         Perl_dump_indent(aTHX_ level, file,
1131                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1132         if (mg->mg_virtual) {
1133             const MGVTBL * const v = mg->mg_virtual;
1134             if (v >= PL_magic_vtables
1135                 && v < PL_magic_vtables + magic_vtable_max) {
1136                 const U32 i = v - PL_magic_vtables;
1137                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1138             }
1139             else
1140                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1141         }
1142         else
1143             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1144
1145         if (mg->mg_private)
1146             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1147
1148         {
1149             int n;
1150             const char *name = NULL;
1151             for (n = 0; magic_names[n].name; n++) {
1152                 if (mg->mg_type == magic_names[n].type) {
1153                     name = magic_names[n].name;
1154                     break;
1155                 }
1156             }
1157             if (name)
1158                 Perl_dump_indent(aTHX_ level, file,
1159                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1160             else
1161                 Perl_dump_indent(aTHX_ level, file,
1162                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1163         }
1164
1165         if (mg->mg_flags) {
1166             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1167             if (mg->mg_type == PERL_MAGIC_envelem &&
1168                 mg->mg_flags & MGf_TAINTEDDIR)
1169                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1170             if (mg->mg_type == PERL_MAGIC_regex_global &&
1171                 mg->mg_flags & MGf_MINMATCH)
1172                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1173             if (mg->mg_flags & MGf_REFCOUNTED)
1174                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1175             if (mg->mg_flags & MGf_GSKIP)
1176                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1177             if (mg->mg_flags & MGf_COPY)
1178                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1179             if (mg->mg_flags & MGf_DUP)
1180                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1181             if (mg->mg_flags & MGf_LOCAL)
1182                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1183             if (mg->mg_type == PERL_MAGIC_regex_global &&
1184                 mg->mg_flags & MGf_BYTES)
1185                 Perl_dump_indent(aTHX_ level, file, "      BYTES\n");
1186         }
1187         if (mg->mg_obj) {
1188             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1189                 PTR2UV(mg->mg_obj));
1190             if (mg->mg_type == PERL_MAGIC_qr) {
1191                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1192                 SV * const dsv = sv_newmortal();
1193                 const char * const s
1194                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1195                     60, NULL, NULL,
1196                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1197                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1198                 );
1199                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1200                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1201                         (IV)RX_REFCNT(re));
1202             }
1203             if (mg->mg_flags & MGf_REFCOUNTED)
1204                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1205         }
1206         if (mg->mg_len)
1207             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1208         if (mg->mg_ptr) {
1209             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1210             if (mg->mg_len >= 0) {
1211                 if (mg->mg_type != PERL_MAGIC_utf8) {
1212                     SV * const sv = newSVpvs("");
1213                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1214                     SvREFCNT_dec_NN(sv);
1215                 }
1216             }
1217             else if (mg->mg_len == HEf_SVKEY) {
1218                 PerlIO_puts(file, " => HEf_SVKEY\n");
1219                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1220                            maxnest, dumpops, pvlim); /* MG is already +1 */
1221                 continue;
1222             }
1223             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1224             else
1225                 PerlIO_puts(
1226                   file,
1227                  " ???? - " __FILE__
1228                  " does not know how to handle this MG_LEN"
1229                 );
1230             PerlIO_putc(file, '\n');
1231         }
1232         if (mg->mg_type == PERL_MAGIC_utf8) {
1233             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1234             if (cache) {
1235                 IV i;
1236                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1237                     Perl_dump_indent(aTHX_ level, file,
1238                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1239                                      i,
1240                                      (UV)cache[i * 2],
1241                                      (UV)cache[i * 2 + 1]);
1242             }
1243         }
1244     }
1245 }
1246
1247 void
1248 Perl_magic_dump(pTHX_ const MAGIC *mg)
1249 {
1250     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1251 }
1252
1253 void
1254 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1255 {
1256     const char *hvname;
1257
1258     PERL_ARGS_ASSERT_DO_HV_DUMP;
1259
1260     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1261     if (sv && (hvname = HvNAME_get(sv)))
1262     {
1263         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1264            name which quite legally could contain insane things like tabs, newlines, nulls or
1265            other scary crap - this should produce sane results - except maybe for unicode package
1266            names - but we will wait for someone to file a bug on that - demerphq */
1267         SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1268         PerlIO_printf(file, "\t\"%s\"\n",
1269                               generic_pv_escape( tmpsv, hvname,
1270                                    HvNAMELEN(sv), HvNAMEUTF8(sv)));
1271     }
1272     else
1273         PerlIO_putc(file, '\n');
1274 }
1275
1276 void
1277 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1278 {
1279     PERL_ARGS_ASSERT_DO_GV_DUMP;
1280
1281     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1282     if (sv && GvNAME(sv)) {
1283         SV * const tmpsv = newSVpvs("");
1284         PerlIO_printf(file, "\t\"%s\"\n",
1285                               generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1286     }
1287     else
1288         PerlIO_putc(file, '\n');
1289 }
1290
1291 void
1292 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1293 {
1294     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1295
1296     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1297     if (sv && GvNAME(sv)) {
1298        SV *tmp = newSVpvs_flags("", SVs_TEMP);
1299         const char *hvname;
1300         HV * const stash = GvSTASH(sv);
1301         PerlIO_printf(file, "\t");
1302    /* TODO might have an extra \" here */
1303         if (stash && (hvname = HvNAME_get(stash))) {
1304             PerlIO_printf(file, "\"%s\" :: \"",
1305                                   generic_pv_escape(tmp, hvname,
1306                                       HvNAMELEN(stash), HvNAMEUTF8(stash)));
1307         }
1308         PerlIO_printf(file, "%s\"\n",
1309                               generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1310     }
1311     else
1312         PerlIO_putc(file, '\n');
1313 }
1314
1315 const struct flag_to_name first_sv_flags_names[] = {
1316     {SVs_TEMP, "TEMP,"},
1317     {SVs_OBJECT, "OBJECT,"},
1318     {SVs_GMG, "GMG,"},
1319     {SVs_SMG, "SMG,"},
1320     {SVs_RMG, "RMG,"},
1321     {SVf_IOK, "IOK,"},
1322     {SVf_NOK, "NOK,"},
1323     {SVf_POK, "POK,"}
1324 };
1325
1326 const struct flag_to_name second_sv_flags_names[] = {
1327     {SVf_OOK, "OOK,"},
1328     {SVf_FAKE, "FAKE,"},
1329     {SVf_READONLY, "READONLY,"},
1330     {SVf_PROTECT, "PROTECT,"},
1331     {SVf_BREAK, "BREAK,"},
1332     {SVp_IOK, "pIOK,"},
1333     {SVp_NOK, "pNOK,"},
1334     {SVp_POK, "pPOK,"}
1335 };
1336
1337 const struct flag_to_name cv_flags_names[] = {
1338     {CVf_ANON, "ANON,"},
1339     {CVf_UNIQUE, "UNIQUE,"},
1340     {CVf_CLONE, "CLONE,"},
1341     {CVf_CLONED, "CLONED,"},
1342     {CVf_CONST, "CONST,"},
1343     {CVf_NODEBUG, "NODEBUG,"},
1344     {CVf_LVALUE, "LVALUE,"},
1345     {CVf_METHOD, "METHOD,"},
1346     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1347     {CVf_CVGV_RC, "CVGV_RC,"},
1348     {CVf_DYNFILE, "DYNFILE,"},
1349     {CVf_AUTOLOAD, "AUTOLOAD,"},
1350     {CVf_HASEVAL, "HASEVAL,"},
1351     {CVf_SLABBED, "SLABBED,"},
1352     {CVf_NAMED, "NAMED,"},
1353     {CVf_LEXICAL, "LEXICAL,"},
1354     {CVf_ISXSUB, "ISXSUB,"}
1355 };
1356
1357 const struct flag_to_name hv_flags_names[] = {
1358     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1359     {SVphv_LAZYDEL, "LAZYDEL,"},
1360     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1361     {SVf_AMAGIC, "OVERLOAD,"},
1362     {SVphv_CLONEABLE, "CLONEABLE,"}
1363 };
1364
1365 const struct flag_to_name gp_flags_names[] = {
1366     {GVf_INTRO, "INTRO,"},
1367     {GVf_MULTI, "MULTI,"},
1368     {GVf_ASSUMECV, "ASSUMECV,"},
1369 };
1370
1371 const struct flag_to_name gp_flags_imported_names[] = {
1372     {GVf_IMPORTED_SV, " SV"},
1373     {GVf_IMPORTED_AV, " AV"},
1374     {GVf_IMPORTED_HV, " HV"},
1375     {GVf_IMPORTED_CV, " CV"},
1376 };
1377
1378 /* NOTE: this structure is mostly duplicative of one generated by
1379  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1380  * the two. - Yves */
1381 const struct flag_to_name regexp_extflags_names[] = {
1382     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1383     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1384     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1385     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1386     {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1387     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1388     {RXf_IS_ANCHORED,     "IS_ANCHORED,"},
1389     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1390     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1391     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1392     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1393     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1394     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1395     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1396     {RXf_SPLIT,           "SPLIT,"},
1397     {RXf_COPY_DONE,       "COPY_DONE,"},
1398     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1399     {RXf_TAINTED,         "TAINTED,"},
1400     {RXf_START_ONLY,      "START_ONLY,"},
1401     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1402     {RXf_WHITE,           "WHITE,"},
1403     {RXf_NULL,            "NULL,"},
1404 };
1405
1406 /* NOTE: this structure is mostly duplicative of one generated by
1407  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1408  * the two. - Yves */
1409 const struct flag_to_name regexp_core_intflags_names[] = {
1410     {PREGf_SKIP,            "SKIP,"},
1411     {PREGf_IMPLICIT,        "IMPLICIT,"},
1412     {PREGf_NAUGHTY,         "NAUGHTY,"},
1413     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1414     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1415     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1416     {PREGf_NOSCAN,          "NOSCAN,"},
1417     {PREGf_CANY_SEEN,       "CANY_SEEN,"},
1418     {PREGf_GPOS_SEEN,       "GPOS_SEEN,"},
1419     {PREGf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1420     {PREGf_ANCH_MBOL,       "ANCH_MBOL,"},
1421     {PREGf_ANCH_SBOL,       "ANCH_SBOL,"},
1422     {PREGf_ANCH_GPOS,       "ANCH_GPOS,"},
1423 };
1424
1425 void
1426 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1427 {
1428     SV *d;
1429     const char *s;
1430     U32 flags;
1431     U32 type;
1432
1433     PERL_ARGS_ASSERT_DO_SV_DUMP;
1434
1435     if (!sv) {
1436         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1437         return;
1438     }
1439
1440     flags = SvFLAGS(sv);
1441     type = SvTYPE(sv);
1442
1443     /* process general SV flags */
1444
1445     d = Perl_newSVpvf(aTHX_
1446                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1447                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1448                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1449                    (int)(PL_dumpindent*level), "");
1450
1451     if (!((flags & SVpad_NAME) == SVpad_NAME
1452           && (type == SVt_PVMG || type == SVt_PVNV))) {
1453         if ((flags & SVs_PADSTALE))
1454             sv_catpv(d, "PADSTALE,");
1455     }
1456     if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1457         if ((flags & SVs_PADTMP))
1458             sv_catpv(d, "PADTMP,");
1459     }
1460     append_flags(d, flags, first_sv_flags_names);
1461     if (flags & SVf_ROK)  {     
1462                                 sv_catpv(d, "ROK,");
1463         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1464     }
1465     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1466     append_flags(d, flags, second_sv_flags_names);
1467     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1468                            && type != SVt_PVAV) {
1469         if (SvPCS_IMPORTED(sv))
1470                                 sv_catpv(d, "PCS_IMPORTED,");
1471         else
1472                                 sv_catpv(d, "SCREAM,");
1473     }
1474
1475     /* process type-specific SV flags */
1476
1477     switch (type) {
1478     case SVt_PVCV:
1479     case SVt_PVFM:
1480         append_flags(d, CvFLAGS(sv), cv_flags_names);
1481         break;
1482     case SVt_PVHV:
1483         append_flags(d, flags, hv_flags_names);
1484         break;
1485     case SVt_PVGV:
1486     case SVt_PVLV:
1487         if (isGV_with_GP(sv)) {
1488             append_flags(d, GvFLAGS(sv), gp_flags_names);
1489         }
1490         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1491             sv_catpv(d, "IMPORT");
1492             if (GvIMPORTED(sv) == GVf_IMPORTED)
1493                 sv_catpv(d, "ALL,");
1494             else {
1495                 sv_catpv(d, "(");
1496                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1497                 sv_catpv(d, " ),");
1498             }
1499         }
1500         /* FALLTHROUGH */
1501     default:
1502     evaled_or_uv:
1503         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1504         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1505         break;
1506     case SVt_PVMG:
1507         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1508         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1509         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1510         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1511         /* FALLTHROUGH */
1512     case SVt_PVNV:
1513         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1514         goto evaled_or_uv;
1515     case SVt_PVAV:
1516         if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
1517         break;
1518     }
1519     /* SVphv_SHAREKEYS is also 0x20000000 */
1520     if ((type != SVt_PVHV) && SvUTF8(sv))
1521         sv_catpv(d, "UTF8");
1522
1523     if (*(SvEND(d) - 1) == ',') {
1524         SvCUR_set(d, SvCUR(d) - 1);
1525         SvPVX(d)[SvCUR(d)] = '\0';
1526     }
1527     sv_catpv(d, ")");
1528     s = SvPVX_const(d);
1529
1530     /* dump initial SV details */
1531
1532 #ifdef DEBUG_LEAKING_SCALARS
1533     Perl_dump_indent(aTHX_ level, file,
1534         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1535         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1536         sv->sv_debug_line,
1537         sv->sv_debug_inpad ? "for" : "by",
1538         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1539         PTR2UV(sv->sv_debug_parent),
1540         sv->sv_debug_serial
1541     );
1542 #endif
1543     Perl_dump_indent(aTHX_ level, file, "SV = ");
1544
1545     /* Dump SV type */
1546
1547     if (type < SVt_LAST) {
1548         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1549
1550         if (type ==  SVt_NULL) {
1551             SvREFCNT_dec_NN(d);
1552             return;
1553         }
1554     } else {
1555         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1556         SvREFCNT_dec_NN(d);
1557         return;
1558     }
1559
1560     /* Dump general SV fields */
1561
1562     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1563          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1564          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1565         || (type == SVt_IV && !SvROK(sv))) {
1566         if (SvIsUV(sv)
1567 #ifdef PERL_OLD_COPY_ON_WRITE
1568                        || SvIsCOW(sv)
1569 #endif
1570                                      )
1571             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1572         else
1573             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1574 #ifdef PERL_OLD_COPY_ON_WRITE
1575         if (SvIsCOW_shared_hash(sv))
1576             PerlIO_printf(file, "  (HASH)");
1577         else if (SvIsCOW_normal(sv))
1578             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1579 #endif
1580         PerlIO_putc(file, '\n');
1581     }
1582
1583     if ((type == SVt_PVNV || type == SVt_PVMG)
1584         && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1585         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1586                          (UV) COP_SEQ_RANGE_LOW(sv));
1587         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1588                          (UV) COP_SEQ_RANGE_HIGH(sv));
1589     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1590                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1591                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1592                || type == SVt_NV) {
1593         STORE_NUMERIC_LOCAL_SET_STANDARD();
1594         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1595         RESTORE_NUMERIC_LOCAL();
1596     }
1597
1598     if (SvROK(sv)) {
1599         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1600         if (nest < maxnest)
1601             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1602     }
1603
1604     if (type < SVt_PV) {
1605         SvREFCNT_dec_NN(d);
1606         return;
1607     }
1608
1609     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1610      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1611         const bool re = isREGEXP(sv);
1612         const char * const ptr =
1613             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1614         if (ptr) {
1615             STRLEN delta;
1616             if (SvOOK(sv)) {
1617                 SvOOK_offset(sv, delta);
1618                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1619                                  (UV) delta);
1620             } else {
1621                 delta = 0;
1622             }
1623             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(ptr));
1624             if (SvOOK(sv)) {
1625                 PerlIO_printf(file, "( %s . ) ",
1626                               pv_display(d, ptr - delta, delta, 0,
1627                                          pvlim));
1628             }
1629             if (type == SVt_INVLIST) {
1630                 PerlIO_printf(file, "\n");
1631                 /* 4 blanks indents 2 beyond the PV, etc */
1632                 _invlist_dump(file, level, "    ", sv);
1633             }
1634             else {
1635                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1636                                                      re ? 0 : SvLEN(sv),
1637                                                      pvlim));
1638                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1639                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1640                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1641                                                         UNI_DISPLAY_QQ));
1642                 PerlIO_printf(file, "\n");
1643             }
1644             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1645             if (!re)
1646                 Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
1647                                        (IV)SvLEN(sv));
1648 #ifdef PERL_NEW_COPY_ON_WRITE
1649             if (SvIsCOW(sv) && SvLEN(sv))
1650                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1651                                        CowREFCNT(sv));
1652 #endif
1653         }
1654         else
1655             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1656     }
1657
1658     if (type >= SVt_PVMG) {
1659         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1660             HV * const ost = SvOURSTASH(sv);
1661             if (ost)
1662                 do_hv_dump(level, file, "  OURSTASH", ost);
1663         } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1664             Perl_dump_indent(aTHX_ level, file, "  MAXNAMED = %"UVuf"\n",
1665                                    (UV)PadnamelistMAXNAMED(sv));
1666         } else {
1667             if (SvMAGIC(sv))
1668                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1669         }
1670         if (SvSTASH(sv))
1671             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1672
1673         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1674             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1675         }
1676     }
1677
1678     /* Dump type-specific SV fields */
1679
1680     switch (type) {
1681     case SVt_PVAV:
1682         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1683         if (AvARRAY(sv) != AvALLOC(sv)) {
1684             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1685             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1686         }
1687         else
1688             PerlIO_putc(file, '\n');
1689         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1690         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1691         /* arylen is stored in magic, and padnamelists use SvMAGIC for
1692            something else. */
1693         if (!AvPAD_NAMELIST(sv))
1694             Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n",
1695                                    SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1696         sv_setpvs(d, "");
1697         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1698         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1699         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1700                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1701         if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1702             SSize_t count;
1703             for (count = 0; count <=  av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1704                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1705
1706                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1707                 if (elt)
1708                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1709             }
1710         }
1711         break;
1712     case SVt_PVHV: {
1713         U32 usedkeys;
1714         if (SvOOK(sv)) {
1715             struct xpvhv_aux *const aux = HvAUX(sv);
1716             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %"UVuf"\n",
1717                              (UV)aux->xhv_aux_flags);
1718         }
1719         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1720         usedkeys = HvUSEDKEYS(sv);
1721         if (HvARRAY(sv) && usedkeys) {
1722             /* Show distribution of HEs in the ARRAY */
1723             int freq[200];
1724 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1725             int i;
1726             int max = 0;
1727             U32 pow2 = 2, keys = usedkeys;
1728             NV theoret, sum = 0;
1729
1730             PerlIO_printf(file, "  (");
1731             Zero(freq, FREQ_MAX + 1, int);
1732             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1733                 HE* h;
1734                 int count = 0;
1735                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1736                     count++;
1737                 if (count > FREQ_MAX)
1738                     count = FREQ_MAX;
1739                 freq[count]++;
1740                 if (max < count)
1741                     max = count;
1742             }
1743             for (i = 0; i <= max; i++) {
1744                 if (freq[i]) {
1745                     PerlIO_printf(file, "%d%s:%d", i,
1746                                   (i == FREQ_MAX) ? "+" : "",
1747                                   freq[i]);
1748                     if (i != max)
1749                         PerlIO_printf(file, ", ");
1750                 }
1751             }
1752             PerlIO_putc(file, ')');
1753             /* The "quality" of a hash is defined as the total number of
1754                comparisons needed to access every element once, relative
1755                to the expected number needed for a random hash.
1756
1757                The total number of comparisons is equal to the sum of
1758                the squares of the number of entries in each bucket.
1759                For a random hash of n keys into k buckets, the expected
1760                value is
1761                                 n + n(n-1)/2k
1762             */
1763
1764             for (i = max; i > 0; i--) { /* Precision: count down. */
1765                 sum += freq[i] * i * i;
1766             }
1767             while ((keys = keys >> 1))
1768                 pow2 = pow2 << 1;
1769             theoret = usedkeys;
1770             theoret += theoret * (theoret-1)/pow2;
1771             PerlIO_putc(file, '\n');
1772             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1773         }
1774         PerlIO_putc(file, '\n');
1775         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)usedkeys);
1776         {
1777             STRLEN count = 0;
1778             HE **ents = HvARRAY(sv);
1779
1780             if (ents) {
1781                 HE *const *const last = ents + HvMAX(sv);
1782                 count = last + 1 - ents;
1783                 
1784                 do {
1785                     if (!*ents)
1786                         --count;
1787                 } while (++ents <= last);
1788             }
1789
1790             if (SvOOK(sv)) {
1791                 struct xpvhv_aux *const aux = HvAUX(sv);
1792                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf
1793                                  " (cached = %"UVuf")\n",
1794                                  (UV)count, (UV)aux->xhv_fill_lazy);
1795             } else {
1796                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
1797                                  (UV)count);
1798             }
1799         }
1800         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1801         if (SvOOK(sv)) {
1802             Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1803             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1804 #ifdef PERL_HASH_RANDOMIZE_KEYS
1805             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1806             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1807                 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1808             }
1809 #endif
1810             PerlIO_putc(file, '\n');
1811         }
1812         {
1813             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1814             if (mg && mg->mg_obj) {
1815                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1816             }
1817         }
1818         {
1819             const char * const hvname = HvNAME_get(sv);
1820             if (hvname) {
1821           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1822      Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1823                                        generic_pv_escape( tmpsv, hvname,
1824                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
1825         }
1826         }
1827         if (SvOOK(sv)) {
1828             AV * const backrefs
1829                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1830             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1831             if (HvAUX(sv)->xhv_name_count)
1832                 Perl_dump_indent(aTHX_
1833                  level, file, "  NAMECOUNT = %"IVdf"\n",
1834                  (IV)HvAUX(sv)->xhv_name_count
1835                 );
1836             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1837                 const I32 count = HvAUX(sv)->xhv_name_count;
1838                 if (count) {
1839                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1840                     /* The starting point is the first element if count is
1841                        positive and the second element if count is negative. */
1842                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1843                         + (count < 0 ? 1 : 0);
1844                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1845                         + (count < 0 ? -count : count);
1846                     while (hekp < endp) {
1847                         if (HEK_LEN(*hekp)) {
1848              SV *tmp = newSVpvs_flags("", SVs_TEMP);
1849                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1850                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1851                         } else {
1852                             /* This should never happen. */
1853                             sv_catpvs(names, ", (null)");
1854                         }
1855                         ++hekp;
1856                     }
1857                     Perl_dump_indent(aTHX_
1858                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1859                     );
1860                 }
1861                 else {
1862                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1863                     const char *const hvename = HvENAME_get(sv);
1864                     Perl_dump_indent(aTHX_
1865                      level, file, "  ENAME = \"%s\"\n",
1866                      generic_pv_escape(tmp, hvename,
1867                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1868                 }
1869             }
1870             if (backrefs) {
1871                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1872                                  PTR2UV(backrefs));
1873                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1874                            dumpops, pvlim);
1875             }
1876             if (meta) {
1877                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1878                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1879                                  generic_pv_escape( tmpsv, meta->mro_which->name,
1880                                 meta->mro_which->length,
1881                                 (meta->mro_which->kflags & HVhek_UTF8)),
1882                                  PTR2UV(meta->mro_which));
1883                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1884                                  (UV)meta->cache_gen);
1885                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1886                                  (UV)meta->pkg_gen);
1887                 if (meta->mro_linear_all) {
1888                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1889                                  PTR2UV(meta->mro_linear_all));
1890                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1891                            dumpops, pvlim);
1892                 }
1893                 if (meta->mro_linear_current) {
1894                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1895                                  PTR2UV(meta->mro_linear_current));
1896                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1897                            dumpops, pvlim);
1898                 }
1899                 if (meta->mro_nextmethod) {
1900                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1901                                  PTR2UV(meta->mro_nextmethod));
1902                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1903                            dumpops, pvlim);
1904                 }
1905                 if (meta->isa) {
1906                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1907                                  PTR2UV(meta->isa));
1908                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1909                            dumpops, pvlim);
1910                 }
1911             }
1912         }
1913         if (nest < maxnest) {
1914             HV * const hv = MUTABLE_HV(sv);
1915             STRLEN i;
1916             HE *he;
1917
1918             if (HvARRAY(hv)) {
1919                 int count = maxnest - nest;
1920                 for (i=0; i <= HvMAX(hv); i++) {
1921                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1922                         U32 hash;
1923                         SV * keysv;
1924                         const char * keypv;
1925                         SV * elt;
1926                         STRLEN len;
1927
1928                         if (count-- <= 0) goto DONEHV;
1929
1930                         hash = HeHASH(he);
1931                         keysv = hv_iterkeysv(he);
1932                         keypv = SvPV_const(keysv, len);
1933                         elt = HeVAL(he);
1934
1935                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1936                         if (SvUTF8(keysv))
1937                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1938                         if (HvEITER_get(hv) == he)
1939                             PerlIO_printf(file, "[CURRENT] ");
1940                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1941                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1942                     }
1943                 }
1944               DONEHV:;
1945             }
1946         }
1947         break;
1948     } /* case SVt_PVHV */
1949
1950     case SVt_PVCV:
1951         if (CvAUTOLOAD(sv)) {
1952             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1953        STRLEN len;
1954             const char *const name =  SvPV_const(sv, len);
1955             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
1956                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1957         }
1958         if (SvPOK(sv)) {
1959        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1960        const char *const proto = CvPROTO(sv);
1961             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
1962                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1963                                 SvUTF8(sv)));
1964         }
1965         /* FALLTHROUGH */
1966     case SVt_PVFM:
1967         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1968         if (!CvISXSUB(sv)) {
1969             if (CvSTART(sv)) {
1970                 Perl_dump_indent(aTHX_ level, file,
1971                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1972                                  PTR2UV(CvSTART(sv)),
1973                                  (IV)sequence_num(CvSTART(sv)));
1974             }
1975             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1976                              PTR2UV(CvROOT(sv)));
1977             if (CvROOT(sv) && dumpops) {
1978                 do_op_dump(level+1, file, CvROOT(sv));
1979             }
1980         } else {
1981             SV * const constant = cv_const_sv((const CV *)sv);
1982
1983             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1984
1985             if (constant) {
1986                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1987                                  " (CONST SV)\n",
1988                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1989                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1990                            pvlim);
1991             } else {
1992                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1993                                  (IV)CvXSUBANY(sv).any_i32);
1994             }
1995         }
1996         if (CvNAMED(sv))
1997             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1998                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
1999         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
2000         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
2001         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2002         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2003         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2004         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2005         if (nest < maxnest) {
2006             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2007         }
2008         {
2009             const CV * const outside = CvOUTSIDE(sv);
2010             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
2011                         PTR2UV(outside),
2012                         (!outside ? "null"
2013                          : CvANON(outside) ? "ANON"
2014                          : (outside == PL_main_cv) ? "MAIN"
2015                          : CvUNIQUE(outside) ? "UNIQUE"
2016                          : CvGV(outside) ?
2017                              generic_pv_escape(
2018                                  newSVpvs_flags("", SVs_TEMP),
2019                                  GvNAME(CvGV(outside)),
2020                                  GvNAMELEN(CvGV(outside)),
2021                                  GvNAMEUTF8(CvGV(outside)))
2022                          : "UNDEFINED"));
2023         }
2024         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2025             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2026         break;
2027
2028     case SVt_PVGV:
2029     case SVt_PVLV:
2030         if (type == SVt_PVLV) {
2031             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2032             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2033             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2034             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2035             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2036             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2037                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2038                     dumpops, pvlim);
2039         }
2040         if (isREGEXP(sv)) goto dumpregexp;
2041         if (!isGV_with_GP(sv))
2042             break;
2043        {
2044           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2045           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2046                     generic_pv_escape(tmpsv, GvNAME(sv),
2047                                       GvNAMELEN(sv),
2048                                       GvNAMEUTF8(sv)));
2049        }
2050         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2051         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2052         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2053         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2054         if (!GvGP(sv))
2055             break;
2056         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2057         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2058         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2059         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2060         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2061         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2062         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2063         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2064         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%"UVxf
2065                                             " (%s)\n",
2066                                (UV)GvGPFLAGS(sv),
2067                                GvALIASED_SV(sv) ? "ALIASED_SV" : "");
2068         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2069         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2070         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2071         break;
2072     case SVt_PVIO:
2073         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2074         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2075         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2076         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2077         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2078         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2079         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2080         if (IoTOP_NAME(sv))
2081             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2082         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2083             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2084         else {
2085             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2086                              PTR2UV(IoTOP_GV(sv)));
2087             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2088                         maxnest, dumpops, pvlim);
2089         }
2090         /* Source filters hide things that are not GVs in these three, so let's
2091            be careful out there.  */
2092         if (IoFMT_NAME(sv))
2093             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2094         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2095             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2096         else {
2097             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2098                              PTR2UV(IoFMT_GV(sv)));
2099             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2100                         maxnest, dumpops, pvlim);
2101         }
2102         if (IoBOTTOM_NAME(sv))
2103             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2104         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2105             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2106         else {
2107             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2108                              PTR2UV(IoBOTTOM_GV(sv)));
2109             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2110                         maxnest, dumpops, pvlim);
2111         }
2112         if (isPRINT(IoTYPE(sv)))
2113             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2114         else
2115             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2116         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2117         break;
2118     case SVt_REGEXP:
2119       dumpregexp:
2120         {
2121             struct regexp * const r = ReANY((REGEXP*)sv);
2122
2123 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2124             sv_setpv(d,"");                                 \
2125             append_flags(d, flags, names);     \
2126             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2127                 SvCUR_set(d, SvCUR(d) - 1);                 \
2128                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2129             }                                               \
2130 } STMT_END
2131             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2132             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
2133                                 (UV)(r->compflags), SvPVX_const(d));
2134
2135             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2136             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2137                                 (UV)(r->extflags), SvPVX_const(d));
2138
2139             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf" (%s)\n",
2140                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2141             if (r->engine == &PL_core_reg_engine) {
2142                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2143                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf" (%s)\n",
2144                                 (UV)(r->intflags), SvPVX_const(d));
2145             } else {
2146                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2147                                 (UV)(r->intflags));
2148             }
2149 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2150             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2151                                 (UV)(r->nparens));
2152             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2153                                 (UV)(r->lastparen));
2154             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2155                                 (UV)(r->lastcloseparen));
2156             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2157                                 (IV)(r->minlen));
2158             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2159                                 (IV)(r->minlenret));
2160             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2161                                 (UV)(r->gofs));
2162             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2163                                 (UV)(r->pre_prefix));
2164             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2165                                 (IV)(r->sublen));
2166             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
2167                                 (IV)(r->suboffset));
2168             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
2169                                 (IV)(r->subcoffset));
2170             if (r->subbeg)
2171                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2172                             PTR2UV(r->subbeg),
2173                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2174             else
2175                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2176             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2177                                 PTR2UV(r->mother_re));
2178             if (nest < maxnest && r->mother_re)
2179                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2180                            maxnest, dumpops, pvlim);
2181             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2182                                 PTR2UV(r->paren_names));
2183             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2184                                 PTR2UV(r->substrs));
2185             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2186                                 PTR2UV(r->pprivate));
2187             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2188                                 PTR2UV(r->offs));
2189             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2190                                 PTR2UV(r->qr_anoncv));
2191 #ifdef PERL_ANY_COW
2192             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2193                                 PTR2UV(r->saved_copy));
2194 #endif
2195         }
2196         break;
2197     }
2198     SvREFCNT_dec_NN(d);
2199 }
2200
2201 /*
2202 =for apidoc sv_dump
2203
2204 Dumps the contents of an SV to the C<STDERR> filehandle.
2205
2206 For an example of its output, see L<Devel::Peek>.
2207
2208 =cut
2209 */
2210
2211 void
2212 Perl_sv_dump(pTHX_ SV *sv)
2213 {
2214     PERL_ARGS_ASSERT_SV_DUMP;
2215
2216     if (SvROK(sv))
2217         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2218     else
2219         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2220 }
2221
2222 int
2223 Perl_runops_debug(pTHX)
2224 {
2225     if (!PL_op) {
2226         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2227         return 0;
2228     }
2229
2230     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2231     do {
2232 #ifdef PERL_TRACE_OPS
2233         ++PL_op_exec_cnt[PL_op->op_type];
2234 #endif
2235         if (PL_debug) {
2236             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2237                 PerlIO_printf(Perl_debug_log,
2238                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2239                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2240                               PTR2UV(*PL_watchaddr));
2241             if (DEBUG_s_TEST_) {
2242                 if (DEBUG_v_TEST_) {
2243                     PerlIO_printf(Perl_debug_log, "\n");
2244                     deb_stack_all();
2245                 }
2246                 else
2247                     debstack();
2248             }
2249
2250
2251             if (DEBUG_t_TEST_) debop(PL_op);
2252             if (DEBUG_P_TEST_) debprof(PL_op);
2253         }
2254
2255         OP_ENTRY_PROBE(OP_NAME(PL_op));
2256     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2257     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2258     PERL_ASYNC_CHECK();
2259
2260     TAINT_NOT;
2261     return 0;
2262 }
2263
2264 I32
2265 Perl_debop(pTHX_ const OP *o)
2266 {
2267     int count;
2268
2269     PERL_ARGS_ASSERT_DEBOP;
2270
2271     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2272         return 0;
2273
2274     Perl_deb(aTHX_ "%s", OP_NAME(o));
2275     switch (o->op_type) {
2276     case OP_CONST:
2277     case OP_HINTSEVAL:
2278         /* With ITHREADS, consts are stored in the pad, and the right pad
2279          * may not be active here, so check.
2280          * Looks like only during compiling the pads are illegal.
2281          */
2282 #ifdef USE_ITHREADS
2283         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2284 #endif
2285             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2286         break;
2287     case OP_GVSV:
2288     case OP_GV:
2289         if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2290             SV * const sv = newSV(0);
2291             gv_fullname3(sv, cGVOPo_gv, NULL);
2292             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2293             SvREFCNT_dec_NN(sv);
2294         }
2295         else if (cGVOPo_gv) {
2296             SV * const sv = newSV(0);
2297             assert(SvROK(cGVOPo_gv));
2298             assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2299             PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2300                     SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2301             SvREFCNT_dec_NN(sv);
2302         }
2303         else
2304             PerlIO_printf(Perl_debug_log, "(NULL)");
2305         break;
2306
2307     case OP_PADSV:
2308     case OP_PADAV:
2309     case OP_PADHV:
2310         count = 1;
2311         goto dump_padop;
2312     case OP_PADRANGE:
2313         count = o->op_private & OPpPADRANGE_COUNTMASK;
2314     dump_padop:
2315         /* print the lexical's name */
2316         {
2317             CV * const cv = deb_curcv(cxstack_ix);
2318             SV *sv;
2319             PAD * comppad = NULL;
2320             int i;
2321
2322             if (cv) {
2323                 PADLIST * const padlist = CvPADLIST(cv);
2324                 comppad = *PadlistARRAY(padlist);
2325             }
2326             PerlIO_printf(Perl_debug_log, "(");
2327             for (i = 0; i < count; i++) {
2328                 if (comppad &&
2329                         (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2330                     PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2331                 else
2332                     PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2333                             (UV)o->op_targ+i);
2334                 if (i < count-1)
2335                     PerlIO_printf(Perl_debug_log, ",");
2336             }
2337             PerlIO_printf(Perl_debug_log, ")");
2338         }
2339         break;
2340
2341     default:
2342         break;
2343     }
2344     PerlIO_printf(Perl_debug_log, "\n");
2345     return 0;
2346 }
2347
2348 STATIC CV*
2349 S_deb_curcv(pTHX_ const I32 ix)
2350 {
2351     const PERL_CONTEXT * const cx = &cxstack[ix];
2352     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2353         return cx->blk_sub.cv;
2354     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2355         return cx->blk_eval.cv;
2356     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2357         return PL_main_cv;
2358     else if (ix <= 0)
2359         return NULL;
2360     else
2361         return deb_curcv(ix - 1);
2362 }
2363
2364 void
2365 Perl_watch(pTHX_ char **addr)
2366 {
2367     PERL_ARGS_ASSERT_WATCH;
2368
2369     PL_watchaddr = addr;
2370     PL_watchok = *addr;
2371     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2372         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2373 }
2374
2375 STATIC void
2376 S_debprof(pTHX_ const OP *o)
2377 {
2378     PERL_ARGS_ASSERT_DEBPROF;
2379
2380     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2381         return;
2382     if (!PL_profiledata)
2383         Newxz(PL_profiledata, MAXO, U32);
2384     ++PL_profiledata[o->op_type];
2385 }
2386
2387 void
2388 Perl_debprofdump(pTHX)
2389 {
2390     unsigned i;
2391     if (!PL_profiledata)
2392         return;
2393     for (i = 0; i < MAXO; i++) {
2394         if (PL_profiledata[i])
2395             PerlIO_printf(Perl_debug_log,
2396                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2397                                        PL_op_name[i]);
2398     }
2399 }
2400
2401
2402 /*
2403  * Local variables:
2404  * c-indentation-style: bsd
2405  * c-basic-offset: 4
2406  * indent-tabs-mode: nil
2407  * End:
2408  *
2409  * ex: set ts=8 sts=4 sw=4 et:
2410  */