This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
silence some gcc -pendantic warnings
[perl5.git] / dump.c
1 /*    dump.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *  'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13  *   it has not been hard for me to read your mind and memory.'
14  *
15  *     [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
16  */
17
18 /* This file contains utility routines to dump the contents of SV and OP
19  * structures, as used by command-line options like -Dt and -Dx, and
20  * by Devel::Peek.
21  *
22  * It also holds the debugging version of the  runops function.
23
24 =head1 Display and Dump functions
25  */
26
27 #include "EXTERN.h"
28 #define PERL_IN_DUMP_C
29 #include "perl.h"
30 #include "regcomp.h"
31
32 static const char* const svtypenames[SVt_LAST] = {
33     "NULL",
34     "IV",
35     "NV",
36     "PV",
37     "INVLIST",
38     "PVIV",
39     "PVNV",
40     "PVMG",
41     "REGEXP",
42     "PVGV",
43     "PVLV",
44     "PVAV",
45     "PVHV",
46     "PVCV",
47     "PVFM",
48     "PVIO"
49 };
50
51
52 static const char* const svshorttypenames[SVt_LAST] = {
53     "UNDEF",
54     "IV",
55     "NV",
56     "PV",
57     "INVLST",
58     "PVIV",
59     "PVNV",
60     "PVMG",
61     "REGEXP",
62     "GV",
63     "PVLV",
64     "AV",
65     "HV",
66     "CV",
67     "FM",
68     "IO"
69 };
70
71 struct flag_to_name {
72     U32 flag;
73     const char *name;
74 };
75
76 static void
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78                const struct flag_to_name *const end)
79 {
80     do {
81         if (flags & start->flag)
82             sv_catpv(sv, start->name);
83     } while (++start < end);
84 }
85
86 #define append_flags(sv, f, flags) \
87     S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
88
89 #define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
90                               (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
91                               PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
92                               | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
93
94 /*
95 =for apidoc pv_escape
96
97 Escapes at most the first "count" chars of pv and puts the results into
98 dsv such that the size of the escaped string will not exceed "max" chars
99 and will not contain any incomplete escape sequences.  The number of bytes
100 escaped will be returned in the STRLEN *escaped parameter if it is not null.
101 When the dsv parameter is null no escaping actually occurs, but the number
102 of bytes that would be escaped were it not null will be calculated.
103
104 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
105 will also be escaped.
106
107 Normally the SV will be cleared before the escaped string is prepared,
108 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
109
110 If PERL_PV_ESCAPE_UNI is set then the input string is treated as UTF-8
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 UTF-8.
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 UTF-8 */
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_LC_NUMERIC_UNDERLYING_SET_STANDARD();
481         Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
482         RESTORE_LC_NUMERIC_UNDERLYING();
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             GV * gv = (GV *)HeVAL(entry);
576             if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
577                 /* unfake a fake GV */
578                 (void)CvGV(SvRV(gv));
579             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
580                 continue;
581             if (GvCVu(gv))
582                 dump_sub_perl(gv, justperl);
583             if (GvFORM(gv))
584                 dump_form(gv);
585             if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
586                 const HV * const hv = GvHV(gv);
587                 if (hv && (hv != PL_defstash))
588                     dump_packsubs_perl(hv, justperl); /* nested package */
589             }
590         }
591     }
592 }
593
594 void
595 Perl_dump_sub(pTHX_ const GV *gv)
596 {
597     PERL_ARGS_ASSERT_DUMP_SUB;
598     dump_sub_perl(gv, FALSE);
599 }
600
601 void
602 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
603 {
604     STRLEN len;
605     SV * const sv = newSVpvs_flags("", SVs_TEMP);
606     SV *tmpsv;
607     const char * name;
608
609     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
610
611     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
612         return;
613
614     tmpsv = newSVpvs_flags("", SVs_TEMP);
615     gv_fullname3(sv, gv, NULL);
616     name = SvPV_const(sv, len);
617     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
618                      generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
619     if (CvISXSUB(GvCV(gv)))
620         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
621             PTR2UV(CvXSUB(GvCV(gv))),
622             (int)CvXSUBANY(GvCV(gv)).any_i32);
623     else if (CvROOT(GvCV(gv)))
624         op_dump(CvROOT(GvCV(gv)));
625     else
626         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
627 }
628
629 void
630 Perl_dump_form(pTHX_ const GV *gv)
631 {
632     SV * const sv = sv_newmortal();
633
634     PERL_ARGS_ASSERT_DUMP_FORM;
635
636     gv_fullname3(sv, gv, NULL);
637     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
638     if (CvROOT(GvFORM(gv)))
639         op_dump(CvROOT(GvFORM(gv)));
640     else
641         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
642 }
643
644 void
645 Perl_dump_eval(pTHX)
646 {
647     op_dump(PL_eval_root);
648 }
649
650 void
651 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
652 {
653     char ch;
654
655     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
656
657     if (!pm) {
658         Perl_dump_indent(aTHX_ level, file, "{}\n");
659         return;
660     }
661     Perl_dump_indent(aTHX_ level, file, "{\n");
662     level++;
663     if (pm->op_pmflags & PMf_ONCE)
664         ch = '?';
665     else
666         ch = '/';
667     if (PM_GETRE(pm))
668         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n",
669              ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch,
670              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
671     else
672         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
673     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
674         Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
675         op_dump(pm->op_pmreplrootu.op_pmreplroot);
676     }
677     if (pm->op_code_list) {
678         if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
679             Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
680             do_op_dump(level, file, pm->op_code_list);
681         }
682         else
683             Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
684                                     PTR2UV(pm->op_code_list));
685     }
686     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
687         SV * const tmpsv = pm_description(pm);
688         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
689         SvREFCNT_dec_NN(tmpsv);
690     }
691
692     Perl_dump_indent(aTHX_ level-1, file, "}\n");
693 }
694
695 const struct flag_to_name pmflags_flags_names[] = {
696     {PMf_CONST, ",CONST"},
697     {PMf_KEEP, ",KEEP"},
698     {PMf_GLOBAL, ",GLOBAL"},
699     {PMf_CONTINUE, ",CONTINUE"},
700     {PMf_RETAINT, ",RETAINT"},
701     {PMf_EVAL, ",EVAL"},
702     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
703     {PMf_HAS_CV, ",HAS_CV"},
704     {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
705     {PMf_IS_QR, ",IS_QR"}
706 };
707
708 static SV *
709 S_pm_description(pTHX_ const PMOP *pm)
710 {
711     SV * const desc = newSVpvs("");
712     const REGEXP * const regex = PM_GETRE(pm);
713     const U32 pmflags = pm->op_pmflags;
714
715     PERL_ARGS_ASSERT_PM_DESCRIPTION;
716
717     if (pmflags & PMf_ONCE)
718         sv_catpv(desc, ",ONCE");
719 #ifdef USE_ITHREADS
720     if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
721         sv_catpv(desc, ":USED");
722 #else
723     if (pmflags & PMf_USED)
724         sv_catpv(desc, ":USED");
725 #endif
726
727     if (regex) {
728         if (RX_ISTAINTED(regex))
729             sv_catpv(desc, ",TAINTED");
730         if (RX_CHECK_SUBSTR(regex)) {
731             if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
732                 sv_catpv(desc, ",SCANFIRST");
733             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
734                 sv_catpv(desc, ",ALL");
735         }
736         if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
737             sv_catpv(desc, ",SKIPWHITE");
738     }
739
740     append_flags(desc, pmflags, pmflags_flags_names);
741     return desc;
742 }
743
744 void
745 Perl_pmop_dump(pTHX_ PMOP *pm)
746 {
747     do_pmop_dump(0, Perl_debug_log, pm);
748 }
749
750 /* Return a unique integer to represent the address of op o.
751  * If it already exists in PL_op_sequence, just return it;
752  * otherwise add it.
753  *  *** Note that this isn't thread-safe */
754
755 STATIC UV
756 S_sequence_num(pTHX_ const OP *o)
757 {
758     dVAR;
759     SV     *op,
760           **seq;
761     const char *key;
762     STRLEN  len;
763     if (!o)
764         return 0;
765     op = newSVuv(PTR2UV(o));
766     sv_2mortal(op);
767     key = SvPV_const(op, len);
768     if (!PL_op_sequence)
769         PL_op_sequence = newHV();
770     seq = hv_fetch(PL_op_sequence, key, len, 0);
771     if (seq)
772         return SvUV(*seq);
773     (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
774     return PL_op_seq;
775 }
776
777
778
779
780
781 const struct flag_to_name op_flags_names[] = {
782     {OPf_KIDS, ",KIDS"},
783     {OPf_PARENS, ",PARENS"},
784     {OPf_REF, ",REF"},
785     {OPf_MOD, ",MOD"},
786     {OPf_STACKED, ",STACKED"},
787     {OPf_SPECIAL, ",SPECIAL"}
788 };
789
790
791 void
792 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
793 {
794     UV      seq;
795     const OPCODE optype = o->op_type;
796
797     PERL_ARGS_ASSERT_DO_OP_DUMP;
798
799     Perl_dump_indent(aTHX_ level, file, "{\n");
800     level++;
801     seq = sequence_num(o);
802     if (seq)
803         PerlIO_printf(file, "%-4"UVuf, seq);
804     else
805         PerlIO_printf(file, "????");
806     PerlIO_printf(file,
807                   "%*sTYPE = %s  ===> ",
808                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
809     if (o->op_next)
810         PerlIO_printf(file,
811                         o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
812                                 sequence_num(o->op_next));
813     else
814         PerlIO_printf(file, "NULL\n");
815     if (o->op_targ) {
816         if (optype == OP_NULL) {
817             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
818         }
819         else
820             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
821     }
822 #ifdef DUMPADDR
823     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
824 #endif
825
826     if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
827         SV * const tmpsv = newSVpvs("");
828         switch (o->op_flags & OPf_WANT) {
829         case OPf_WANT_VOID:
830             sv_catpv(tmpsv, ",VOID");
831             break;
832         case OPf_WANT_SCALAR:
833             sv_catpv(tmpsv, ",SCALAR");
834             break;
835         case OPf_WANT_LIST:
836             sv_catpv(tmpsv, ",LIST");
837             break;
838         default:
839             sv_catpv(tmpsv, ",UNKNOWN");
840             break;
841         }
842         append_flags(tmpsv, o->op_flags, op_flags_names);
843         if (o->op_slabbed)  sv_catpvs(tmpsv, ",SLABBED");
844         if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
845         if (o->op_static)   sv_catpvs(tmpsv, ",STATIC");
846         if (o->op_folded)   sv_catpvs(tmpsv, ",FOLDED");
847         if (o->op_moresib)  sv_catpvs(tmpsv, ",MORESIB");
848         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
849                          SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
850     }
851
852     if (o->op_private) {
853         U16 oppriv = o->op_private;
854         I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
855         SV * tmpsv = NULL;
856
857         if (op_ix != -1) {
858             U16 stop = 0;
859             tmpsv = newSVpvs("");
860             for (; !stop; op_ix++) {
861                 U16 entry = PL_op_private_bitdefs[op_ix];
862                 U16 bit = (entry >> 2) & 7;
863                 U16 ix = entry >> 5;
864
865                 stop = (entry & 1);
866
867                 if (entry & 2) {
868                     /* bitfield */
869                     I16 const *p = &PL_op_private_bitfields[ix];
870                     U16 bitmin = (U16) *p++;
871                     I16 label = *p++;
872                     I16 enum_label;
873                     U16 mask = 0;
874                     U16 i;
875                     U16 val;
876
877                     for (i = bitmin; i<= bit; i++)
878                         mask |= (1<<i);
879                     bit = bitmin;
880                     val = (oppriv & mask);
881
882                     if (   label != -1
883                         && PL_op_private_labels[label] == '-'
884                         && PL_op_private_labels[label+1] == '\0'
885                     )
886                         /* display as raw number */
887                         continue;
888
889                     oppriv -= val;
890                     val >>= bit;
891                     enum_label = -1;
892                     while (*p != -1) {
893                         if (val == *p++) {
894                             enum_label = *p;
895                             break;
896                         }
897                         p++;
898                     }
899                     if (val == 0 && enum_label == -1)
900                         /* don't display anonymous zero values */
901                         continue;
902
903                     sv_catpv(tmpsv, ",");
904                     if (label != -1) {
905                         sv_catpv(tmpsv, &PL_op_private_labels[label]);
906                         sv_catpv(tmpsv, "=");
907                     }
908                     if (enum_label == -1)
909                         Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)val);
910                     else
911                         sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
912
913                 }
914                 else {
915                     /* bit flag */
916                     if (   oppriv & (1<<bit)
917                         && !(PL_op_private_labels[ix] == '-'
918                              && PL_op_private_labels[ix+1] == '\0'))
919                     {
920                         oppriv -= (1<<bit);
921                         sv_catpv(tmpsv, ",");
922                         sv_catpv(tmpsv, &PL_op_private_labels[ix]);
923                     }
924                 }
925             }
926             if (oppriv) {
927                 sv_catpv(tmpsv, ",");
928                 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
929             }
930         }
931         if (tmpsv && SvCUR(tmpsv)) {
932             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
933         } else
934             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
935                              (UV)oppriv);
936     }
937
938     switch (optype) {
939     case OP_AELEMFAST:
940     case OP_GVSV:
941     case OP_GV:
942 #ifdef USE_ITHREADS
943         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
944 #else
945         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
946             if (cSVOPo->op_sv) {
947       STRLEN len;
948       const char * name;
949       SV * const tmpsv  = newSVpvs_flags("", SVs_TEMP);
950       SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
951                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
952       name = SvPV_const(tmpsv, len);
953                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
954                        generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
955             }
956             else
957                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
958         }
959 #endif
960         break;
961
962     case OP_MULTIDEREF:
963     {
964         UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
965         UV i, count = items[-1].uv;
966
967         Perl_dump_indent(aTHX_ level, file, "ARGS = \n");
968         for (i=0; i < count;  i++)
969             Perl_dump_indent(aTHX_ level+1, file, "%"UVuf" => 0x%"UVxf"\n",
970                                     i, items[i].uv);
971     }
972
973     case OP_CONST:
974     case OP_HINTSEVAL:
975     case OP_METHOD_NAMED:
976     case OP_METHOD_SUPER:
977     case OP_METHOD_REDIR:
978     case OP_METHOD_REDIR_SUPER:
979 #ifndef USE_ITHREADS
980         /* with ITHREADS, consts are stored in the pad, and the right pad
981          * may not be active here, so skip */
982         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
983 #endif
984         break;
985     case OP_NULL:
986         if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
987             break;
988         /* FALLTHROUGH */
989     case OP_NEXTSTATE:
990     case OP_DBSTATE:
991         if (CopLINE(cCOPo))
992             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
993                              (UV)CopLINE(cCOPo));
994     if (CopSTASHPV(cCOPo)) {
995         SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
996         HV *stash = CopSTASH(cCOPo);
997         const char * const hvname = HvNAME_get(stash);
998         
999             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1000                            generic_pv_escape(tmpsv, hvname,
1001                               HvNAMELEN(stash), HvNAMEUTF8(stash)));
1002     }
1003   if (CopLABEL(cCOPo)) {
1004        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1005        STRLEN label_len;
1006        U32 label_flags;
1007        const char *label = CopLABEL_len_flags(cCOPo,
1008                                                 &label_len, &label_flags);
1009        Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1010                            generic_pv_escape( tmpsv, label, label_len,
1011                                       (label_flags & SVf_UTF8)));
1012    }
1013         Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
1014                          (unsigned int)cCOPo->cop_seq);
1015         break;
1016     case OP_ENTERLOOP:
1017         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1018         if (cLOOPo->op_redoop)
1019             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1020         else
1021             PerlIO_printf(file, "DONE\n");
1022         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1023         if (cLOOPo->op_nextop)
1024             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1025         else
1026             PerlIO_printf(file, "DONE\n");
1027         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1028         if (cLOOPo->op_lastop)
1029             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1030         else
1031             PerlIO_printf(file, "DONE\n");
1032         break;
1033     case OP_COND_EXPR:
1034     case OP_RANGE:
1035     case OP_MAPWHILE:
1036     case OP_GREPWHILE:
1037     case OP_OR:
1038     case OP_AND:
1039         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1040         if (cLOGOPo->op_other)
1041             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1042         else
1043             PerlIO_printf(file, "DONE\n");
1044         break;
1045     case OP_PUSHRE:
1046     case OP_MATCH:
1047     case OP_QR:
1048     case OP_SUBST:
1049         do_pmop_dump(level, file, cPMOPo);
1050         break;
1051     case OP_LEAVE:
1052     case OP_LEAVEEVAL:
1053     case OP_LEAVESUB:
1054     case OP_LEAVESUBLV:
1055     case OP_LEAVEWRITE:
1056     case OP_SCOPE:
1057         if (o->op_private & OPpREFCOUNTED)
1058             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1059         break;
1060     default:
1061         break;
1062     }
1063     if (o->op_flags & OPf_KIDS) {
1064         OP *kid;
1065         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1066             do_op_dump(level, file, kid);
1067     }
1068     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1069 }
1070
1071 /*
1072 =for apidoc op_dump
1073
1074 Dumps the optree starting at OP C<o> to C<STDERR>.
1075
1076 =cut
1077 */
1078
1079 void
1080 Perl_op_dump(pTHX_ const OP *o)
1081 {
1082     PERL_ARGS_ASSERT_OP_DUMP;
1083     do_op_dump(0, Perl_debug_log, o);
1084 }
1085
1086 void
1087 Perl_gv_dump(pTHX_ GV *gv)
1088 {
1089     STRLEN len;
1090     const char* name;
1091     SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
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_PMf_NOCAPTURE,   "PMf_NOCAPURE,"},
1389     {RXf_IS_ANCHORED,     "IS_ANCHORED,"},
1390     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1391     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1392     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1393     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1394     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1395     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1396     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1397     {RXf_SPLIT,           "SPLIT,"},
1398     {RXf_COPY_DONE,       "COPY_DONE,"},
1399     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1400     {RXf_TAINTED,         "TAINTED,"},
1401     {RXf_START_ONLY,      "START_ONLY,"},
1402     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1403     {RXf_WHITE,           "WHITE,"},
1404     {RXf_NULL,            "NULL,"},
1405 };
1406
1407 /* NOTE: this structure is mostly duplicative of one generated by
1408  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1409  * the two. - Yves */
1410 const struct flag_to_name regexp_core_intflags_names[] = {
1411     {PREGf_SKIP,            "SKIP,"},
1412     {PREGf_IMPLICIT,        "IMPLICIT,"},
1413     {PREGf_NAUGHTY,         "NAUGHTY,"},
1414     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1415     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1416     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1417     {PREGf_NOSCAN,          "NOSCAN,"},
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 & SVs_PADSTALE))
1452             sv_catpv(d, "PADSTALE,");
1453     if ((flags & SVs_PADTMP))
1454             sv_catpv(d, "PADTMP,");
1455     append_flags(d, flags, first_sv_flags_names);
1456     if (flags & SVf_ROK)  {     
1457                                 sv_catpv(d, "ROK,");
1458         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1459     }
1460     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1461     append_flags(d, flags, second_sv_flags_names);
1462     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1463                            && type != SVt_PVAV) {
1464         if (SvPCS_IMPORTED(sv))
1465                                 sv_catpv(d, "PCS_IMPORTED,");
1466         else
1467                                 sv_catpv(d, "SCREAM,");
1468     }
1469
1470     /* process type-specific SV flags */
1471
1472     switch (type) {
1473     case SVt_PVCV:
1474     case SVt_PVFM:
1475         append_flags(d, CvFLAGS(sv), cv_flags_names);
1476         break;
1477     case SVt_PVHV:
1478         append_flags(d, flags, hv_flags_names);
1479         break;
1480     case SVt_PVGV:
1481     case SVt_PVLV:
1482         if (isGV_with_GP(sv)) {
1483             append_flags(d, GvFLAGS(sv), gp_flags_names);
1484         }
1485         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1486             sv_catpv(d, "IMPORT");
1487             if (GvIMPORTED(sv) == GVf_IMPORTED)
1488                 sv_catpv(d, "ALL,");
1489             else {
1490                 sv_catpv(d, "(");
1491                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1492                 sv_catpv(d, " ),");
1493             }
1494         }
1495         /* FALLTHROUGH */
1496     default:
1497     evaled_or_uv:
1498         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1499         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1500         break;
1501     case SVt_PVMG:
1502         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1503         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1504         /* FALLTHROUGH */
1505         goto evaled_or_uv;
1506     case SVt_PVAV:
1507         break;
1508     }
1509     /* SVphv_SHAREKEYS is also 0x20000000 */
1510     if ((type != SVt_PVHV) && SvUTF8(sv))
1511         sv_catpv(d, "UTF8");
1512
1513     if (*(SvEND(d) - 1) == ',') {
1514         SvCUR_set(d, SvCUR(d) - 1);
1515         SvPVX(d)[SvCUR(d)] = '\0';
1516     }
1517     sv_catpv(d, ")");
1518     s = SvPVX_const(d);
1519
1520     /* dump initial SV details */
1521
1522 #ifdef DEBUG_LEAKING_SCALARS
1523     Perl_dump_indent(aTHX_ level, file,
1524         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1525         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1526         sv->sv_debug_line,
1527         sv->sv_debug_inpad ? "for" : "by",
1528         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1529         PTR2UV(sv->sv_debug_parent),
1530         sv->sv_debug_serial
1531     );
1532 #endif
1533     Perl_dump_indent(aTHX_ level, file, "SV = ");
1534
1535     /* Dump SV type */
1536
1537     if (type < SVt_LAST) {
1538         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1539
1540         if (type ==  SVt_NULL) {
1541             SvREFCNT_dec_NN(d);
1542             return;
1543         }
1544     } else {
1545         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1546         SvREFCNT_dec_NN(d);
1547         return;
1548     }
1549
1550     /* Dump general SV fields */
1551
1552     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1553          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1554          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1555         || (type == SVt_IV && !SvROK(sv))) {
1556         if (SvIsUV(sv)
1557 #ifdef PERL_OLD_COPY_ON_WRITE
1558                        || SvIsCOW(sv)
1559 #endif
1560                                      )
1561             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1562         else
1563             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1564 #ifdef PERL_OLD_COPY_ON_WRITE
1565         if (SvIsCOW_shared_hash(sv))
1566             PerlIO_printf(file, "  (HASH)");
1567         else if (SvIsCOW_normal(sv))
1568             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1569 #endif
1570         PerlIO_putc(file, '\n');
1571     }
1572
1573     if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1574                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1575                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1576                || type == SVt_NV) {
1577         STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1578         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1579         RESTORE_LC_NUMERIC_UNDERLYING();
1580     }
1581
1582     if (SvROK(sv)) {
1583         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1584         if (nest < maxnest)
1585             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1586     }
1587
1588     if (type < SVt_PV) {
1589         SvREFCNT_dec_NN(d);
1590         return;
1591     }
1592
1593     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1594      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1595         const bool re = isREGEXP(sv);
1596         const char * const ptr =
1597             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1598         if (ptr) {
1599             STRLEN delta;
1600             if (SvOOK(sv)) {
1601                 SvOOK_offset(sv, delta);
1602                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1603                                  (UV) delta);
1604             } else {
1605                 delta = 0;
1606             }
1607             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(ptr));
1608             if (SvOOK(sv)) {
1609                 PerlIO_printf(file, "( %s . ) ",
1610                               pv_display(d, ptr - delta, delta, 0,
1611                                          pvlim));
1612             }
1613             if (type == SVt_INVLIST) {
1614                 PerlIO_printf(file, "\n");
1615                 /* 4 blanks indents 2 beyond the PV, etc */
1616                 _invlist_dump(file, level, "    ", sv);
1617             }
1618             else {
1619                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1620                                                      re ? 0 : SvLEN(sv),
1621                                                      pvlim));
1622                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1623                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1624                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1625                                                         UNI_DISPLAY_QQ));
1626                 PerlIO_printf(file, "\n");
1627             }
1628             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1629             if (!re)
1630                 Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
1631                                        (IV)SvLEN(sv));
1632 #ifdef PERL_NEW_COPY_ON_WRITE
1633             if (SvIsCOW(sv) && SvLEN(sv))
1634                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1635                                        CowREFCNT(sv));
1636 #endif
1637         }
1638         else
1639             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1640     }
1641
1642     if (type >= SVt_PVMG) {
1643         if (SvMAGIC(sv))
1644                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1645         if (SvSTASH(sv))
1646             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1647
1648         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1649             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1650         }
1651     }
1652
1653     /* Dump type-specific SV fields */
1654
1655     switch (type) {
1656     case SVt_PVAV:
1657         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1658         if (AvARRAY(sv) != AvALLOC(sv)) {
1659             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1660             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1661         }
1662         else
1663             PerlIO_putc(file, '\n');
1664         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1665         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1666         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n",
1667                                    SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1668         sv_setpvs(d, "");
1669         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1670         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1671         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1672                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1673         if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1674             SSize_t count;
1675             for (count = 0; count <=  av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1676                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1677
1678                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1679                 if (elt)
1680                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1681             }
1682         }
1683         break;
1684     case SVt_PVHV: {
1685         U32 usedkeys;
1686         if (SvOOK(sv)) {
1687             struct xpvhv_aux *const aux = HvAUX(sv);
1688             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %"UVuf"\n",
1689                              (UV)aux->xhv_aux_flags);
1690         }
1691         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1692         usedkeys = HvUSEDKEYS(sv);
1693         if (HvARRAY(sv) && usedkeys) {
1694             /* Show distribution of HEs in the ARRAY */
1695             int freq[200];
1696 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1697             int i;
1698             int max = 0;
1699             U32 pow2 = 2, keys = usedkeys;
1700             NV theoret, sum = 0;
1701
1702             PerlIO_printf(file, "  (");
1703             Zero(freq, FREQ_MAX + 1, int);
1704             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1705                 HE* h;
1706                 int count = 0;
1707                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1708                     count++;
1709                 if (count > FREQ_MAX)
1710                     count = FREQ_MAX;
1711                 freq[count]++;
1712                 if (max < count)
1713                     max = count;
1714             }
1715             for (i = 0; i <= max; i++) {
1716                 if (freq[i]) {
1717                     PerlIO_printf(file, "%d%s:%d", i,
1718                                   (i == FREQ_MAX) ? "+" : "",
1719                                   freq[i]);
1720                     if (i != max)
1721                         PerlIO_printf(file, ", ");
1722                 }
1723             }
1724             PerlIO_putc(file, ')');
1725             /* The "quality" of a hash is defined as the total number of
1726                comparisons needed to access every element once, relative
1727                to the expected number needed for a random hash.
1728
1729                The total number of comparisons is equal to the sum of
1730                the squares of the number of entries in each bucket.
1731                For a random hash of n keys into k buckets, the expected
1732                value is
1733                                 n + n(n-1)/2k
1734             */
1735
1736             for (i = max; i > 0; i--) { /* Precision: count down. */
1737                 sum += freq[i] * i * i;
1738             }
1739             while ((keys = keys >> 1))
1740                 pow2 = pow2 << 1;
1741             theoret = usedkeys;
1742             theoret += theoret * (theoret-1)/pow2;
1743             PerlIO_putc(file, '\n');
1744             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1745         }
1746         PerlIO_putc(file, '\n');
1747         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)usedkeys);
1748         {
1749             STRLEN count = 0;
1750             HE **ents = HvARRAY(sv);
1751
1752             if (ents) {
1753                 HE *const *const last = ents + HvMAX(sv);
1754                 count = last + 1 - ents;
1755                 
1756                 do {
1757                     if (!*ents)
1758                         --count;
1759                 } while (++ents <= last);
1760             }
1761
1762             if (SvOOK(sv)) {
1763                 struct xpvhv_aux *const aux = HvAUX(sv);
1764                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf
1765                                  " (cached = %"UVuf")\n",
1766                                  (UV)count, (UV)aux->xhv_fill_lazy);
1767             } else {
1768                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
1769                                  (UV)count);
1770             }
1771         }
1772         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1773         if (SvOOK(sv)) {
1774             Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1775             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1776 #ifdef PERL_HASH_RANDOMIZE_KEYS
1777             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1778             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1779                 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1780             }
1781 #endif
1782             PerlIO_putc(file, '\n');
1783         }
1784         {
1785             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1786             if (mg && mg->mg_obj) {
1787                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1788             }
1789         }
1790         {
1791             const char * const hvname = HvNAME_get(sv);
1792             if (hvname) {
1793           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1794      Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1795                                        generic_pv_escape( tmpsv, hvname,
1796                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
1797         }
1798         }
1799         if (SvOOK(sv)) {
1800             AV * const backrefs
1801                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1802             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1803             if (HvAUX(sv)->xhv_name_count)
1804                 Perl_dump_indent(aTHX_
1805                  level, file, "  NAMECOUNT = %"IVdf"\n",
1806                  (IV)HvAUX(sv)->xhv_name_count
1807                 );
1808             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1809                 const I32 count = HvAUX(sv)->xhv_name_count;
1810                 if (count) {
1811                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1812                     /* The starting point is the first element if count is
1813                        positive and the second element if count is negative. */
1814                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1815                         + (count < 0 ? 1 : 0);
1816                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1817                         + (count < 0 ? -count : count);
1818                     while (hekp < endp) {
1819                         if (HEK_LEN(*hekp)) {
1820              SV *tmp = newSVpvs_flags("", SVs_TEMP);
1821                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1822                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1823                         } else {
1824                             /* This should never happen. */
1825                             sv_catpvs(names, ", (null)");
1826                         }
1827                         ++hekp;
1828                     }
1829                     Perl_dump_indent(aTHX_
1830                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1831                     );
1832                 }
1833                 else {
1834                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1835                     const char *const hvename = HvENAME_get(sv);
1836                     Perl_dump_indent(aTHX_
1837                      level, file, "  ENAME = \"%s\"\n",
1838                      generic_pv_escape(tmp, hvename,
1839                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1840                 }
1841             }
1842             if (backrefs) {
1843                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1844                                  PTR2UV(backrefs));
1845                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1846                            dumpops, pvlim);
1847             }
1848             if (meta) {
1849                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1850                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1851                                  generic_pv_escape( tmpsv, meta->mro_which->name,
1852                                 meta->mro_which->length,
1853                                 (meta->mro_which->kflags & HVhek_UTF8)),
1854                                  PTR2UV(meta->mro_which));
1855                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1856                                  (UV)meta->cache_gen);
1857                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1858                                  (UV)meta->pkg_gen);
1859                 if (meta->mro_linear_all) {
1860                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1861                                  PTR2UV(meta->mro_linear_all));
1862                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1863                            dumpops, pvlim);
1864                 }
1865                 if (meta->mro_linear_current) {
1866                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1867                                  PTR2UV(meta->mro_linear_current));
1868                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1869                            dumpops, pvlim);
1870                 }
1871                 if (meta->mro_nextmethod) {
1872                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1873                                  PTR2UV(meta->mro_nextmethod));
1874                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1875                            dumpops, pvlim);
1876                 }
1877                 if (meta->isa) {
1878                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1879                                  PTR2UV(meta->isa));
1880                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1881                            dumpops, pvlim);
1882                 }
1883             }
1884         }
1885         if (nest < maxnest) {
1886             HV * const hv = MUTABLE_HV(sv);
1887             STRLEN i;
1888             HE *he;
1889
1890             if (HvARRAY(hv)) {
1891                 int count = maxnest - nest;
1892                 for (i=0; i <= HvMAX(hv); i++) {
1893                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1894                         U32 hash;
1895                         SV * keysv;
1896                         const char * keypv;
1897                         SV * elt;
1898                         STRLEN len;
1899
1900                         if (count-- <= 0) goto DONEHV;
1901
1902                         hash = HeHASH(he);
1903                         keysv = hv_iterkeysv(he);
1904                         keypv = SvPV_const(keysv, len);
1905                         elt = HeVAL(he);
1906
1907                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1908                         if (SvUTF8(keysv))
1909                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1910                         if (HvEITER_get(hv) == he)
1911                             PerlIO_printf(file, "[CURRENT] ");
1912                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1913                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1914                     }
1915                 }
1916               DONEHV:;
1917             }
1918         }
1919         break;
1920     } /* case SVt_PVHV */
1921
1922     case SVt_PVCV:
1923         if (CvAUTOLOAD(sv)) {
1924             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1925        STRLEN len;
1926             const char *const name =  SvPV_const(sv, len);
1927             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
1928                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1929         }
1930         if (SvPOK(sv)) {
1931        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1932        const char *const proto = CvPROTO(sv);
1933             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
1934                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1935                                 SvUTF8(sv)));
1936         }
1937         /* FALLTHROUGH */
1938     case SVt_PVFM:
1939         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1940         if (!CvISXSUB(sv)) {
1941             if (CvSTART(sv)) {
1942                 Perl_dump_indent(aTHX_ level, file,
1943                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1944                                  PTR2UV(CvSTART(sv)),
1945                                  (IV)sequence_num(CvSTART(sv)));
1946             }
1947             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1948                              PTR2UV(CvROOT(sv)));
1949             if (CvROOT(sv) && dumpops) {
1950                 do_op_dump(level+1, file, CvROOT(sv));
1951             }
1952         } else {
1953             SV * const constant = cv_const_sv((const CV *)sv);
1954
1955             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1956
1957             if (constant) {
1958                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1959                                  " (CONST SV)\n",
1960                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1961                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1962                            pvlim);
1963             } else {
1964                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1965                                  (IV)CvXSUBANY(sv).any_i32);
1966             }
1967         }
1968         if (CvNAMED(sv))
1969             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1970                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
1971         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1972         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1973         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1974         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1975         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1976         if (!CvISXSUB(sv)) {
1977             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1978             if (nest < maxnest) {
1979                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1980             }
1981         }
1982         else
1983             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
1984         {
1985             const CV * const outside = CvOUTSIDE(sv);
1986             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1987                         PTR2UV(outside),
1988                         (!outside ? "null"
1989                          : CvANON(outside) ? "ANON"
1990                          : (outside == PL_main_cv) ? "MAIN"
1991                          : CvUNIQUE(outside) ? "UNIQUE"
1992                          : CvGV(outside) ?
1993                              generic_pv_escape(
1994                                  newSVpvs_flags("", SVs_TEMP),
1995                                  GvNAME(CvGV(outside)),
1996                                  GvNAMELEN(CvGV(outside)),
1997                                  GvNAMEUTF8(CvGV(outside)))
1998                          : "UNDEFINED"));
1999         }
2000         if (CvOUTSIDE(sv)
2001          && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2002             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2003         break;
2004
2005     case SVt_PVGV:
2006     case SVt_PVLV:
2007         if (type == SVt_PVLV) {
2008             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2009             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2010             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2011             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2012             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2013             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2014                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2015                     dumpops, pvlim);
2016         }
2017         if (isREGEXP(sv)) goto dumpregexp;
2018         if (!isGV_with_GP(sv))
2019             break;
2020        {
2021           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2022           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2023                     generic_pv_escape(tmpsv, GvNAME(sv),
2024                                       GvNAMELEN(sv),
2025                                       GvNAMEUTF8(sv)));
2026        }
2027         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2028         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2029         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2030         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2031         if (!GvGP(sv))
2032             break;
2033         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2034         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2035         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2036         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2037         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2038         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2039         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2040         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2041         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%"UVxf
2042                                             " (%s)\n",
2043                                (UV)GvGPFLAGS(sv),
2044                                GvALIASED_SV(sv) ? "ALIASED_SV" : "");
2045         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2046         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2047         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2048         break;
2049     case SVt_PVIO:
2050         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2051         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2052         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2053         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2054         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2055         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2056         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2057         if (IoTOP_NAME(sv))
2058             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2059         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2060             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2061         else {
2062             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2063                              PTR2UV(IoTOP_GV(sv)));
2064             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2065                         maxnest, dumpops, pvlim);
2066         }
2067         /* Source filters hide things that are not GVs in these three, so let's
2068            be careful out there.  */
2069         if (IoFMT_NAME(sv))
2070             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2071         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2072             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2073         else {
2074             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2075                              PTR2UV(IoFMT_GV(sv)));
2076             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2077                         maxnest, dumpops, pvlim);
2078         }
2079         if (IoBOTTOM_NAME(sv))
2080             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2081         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2082             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2083         else {
2084             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2085                              PTR2UV(IoBOTTOM_GV(sv)));
2086             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2087                         maxnest, dumpops, pvlim);
2088         }
2089         if (isPRINT(IoTYPE(sv)))
2090             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2091         else
2092             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2093         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2094         break;
2095     case SVt_REGEXP:
2096       dumpregexp:
2097         {
2098             struct regexp * const r = ReANY((REGEXP*)sv);
2099
2100 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2101             sv_setpv(d,"");                                 \
2102             append_flags(d, flags, names);     \
2103             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2104                 SvCUR_set(d, SvCUR(d) - 1);                 \
2105                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2106             }                                               \
2107 } STMT_END
2108             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2109             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
2110                                 (UV)(r->compflags), SvPVX_const(d));
2111
2112             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2113             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2114                                 (UV)(r->extflags), SvPVX_const(d));
2115
2116             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf" (%s)\n",
2117                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2118             if (r->engine == &PL_core_reg_engine) {
2119                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2120                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf" (%s)\n",
2121                                 (UV)(r->intflags), SvPVX_const(d));
2122             } else {
2123                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2124                                 (UV)(r->intflags));
2125             }
2126 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2127             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2128                                 (UV)(r->nparens));
2129             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2130                                 (UV)(r->lastparen));
2131             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2132                                 (UV)(r->lastcloseparen));
2133             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2134                                 (IV)(r->minlen));
2135             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2136                                 (IV)(r->minlenret));
2137             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2138                                 (UV)(r->gofs));
2139             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2140                                 (UV)(r->pre_prefix));
2141             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2142                                 (IV)(r->sublen));
2143             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
2144                                 (IV)(r->suboffset));
2145             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
2146                                 (IV)(r->subcoffset));
2147             if (r->subbeg)
2148                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2149                             PTR2UV(r->subbeg),
2150                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2151             else
2152                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2153             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2154                                 PTR2UV(r->mother_re));
2155             if (nest < maxnest && r->mother_re)
2156                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2157                            maxnest, dumpops, pvlim);
2158             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2159                                 PTR2UV(r->paren_names));
2160             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2161                                 PTR2UV(r->substrs));
2162             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2163                                 PTR2UV(r->pprivate));
2164             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2165                                 PTR2UV(r->offs));
2166             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2167                                 PTR2UV(r->qr_anoncv));
2168 #ifdef PERL_ANY_COW
2169             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2170                                 PTR2UV(r->saved_copy));
2171 #endif
2172         }
2173         break;
2174     }
2175     SvREFCNT_dec_NN(d);
2176 }
2177
2178 /*
2179 =for apidoc sv_dump
2180
2181 Dumps the contents of an SV to the C<STDERR> filehandle.
2182
2183 For an example of its output, see L<Devel::Peek>.
2184
2185 =cut
2186 */
2187
2188 void
2189 Perl_sv_dump(pTHX_ SV *sv)
2190 {
2191     PERL_ARGS_ASSERT_SV_DUMP;
2192
2193     if (SvROK(sv))
2194         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2195     else
2196         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2197 }
2198
2199 int
2200 Perl_runops_debug(pTHX)
2201 {
2202     if (!PL_op) {
2203         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2204         return 0;
2205     }
2206
2207     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2208     do {
2209 #ifdef PERL_TRACE_OPS
2210         ++PL_op_exec_cnt[PL_op->op_type];
2211 #endif
2212         if (PL_debug) {
2213             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2214                 PerlIO_printf(Perl_debug_log,
2215                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2216                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2217                               PTR2UV(*PL_watchaddr));
2218             if (DEBUG_s_TEST_) {
2219                 if (DEBUG_v_TEST_) {
2220                     PerlIO_printf(Perl_debug_log, "\n");
2221                     deb_stack_all();
2222                 }
2223                 else
2224                     debstack();
2225             }
2226
2227
2228             if (DEBUG_t_TEST_) debop(PL_op);
2229             if (DEBUG_P_TEST_) debprof(PL_op);
2230         }
2231
2232         OP_ENTRY_PROBE(OP_NAME(PL_op));
2233     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2234     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2235     PERL_ASYNC_CHECK();
2236
2237     TAINT_NOT;
2238     return 0;
2239 }
2240
2241
2242 /* print the names of the n lexical vars starting at pad offset off */
2243
2244 void
2245 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2246 {
2247     PADNAME *sv;
2248     CV * const cv = deb_curcv(cxstack_ix);
2249     PADNAMELIST *comppad = NULL;
2250     int i;
2251
2252     if (cv) {
2253         PADLIST * const padlist = CvPADLIST(cv);
2254         comppad = PadlistNAMES(padlist);
2255     }
2256     if (paren)
2257         PerlIO_printf(Perl_debug_log, "(");
2258     for (i = 0; i < n; i++) {
2259         if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2260             PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2261         else
2262             PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2263                     (UV)(off+i));
2264         if (i < n - 1)
2265             PerlIO_printf(Perl_debug_log, ",");
2266     }
2267     if (paren)
2268         PerlIO_printf(Perl_debug_log, ")");
2269 }
2270
2271
2272 /* append to the out SV, the name of the lexical at offset off in the CV
2273  * cv */
2274
2275 static void
2276 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2277         bool paren, bool is_scalar)
2278 {
2279     PADNAME *sv;
2280     PADNAMELIST *namepad = NULL;
2281     int i;
2282
2283     if (cv) {
2284         PADLIST * const padlist = CvPADLIST(cv);
2285         namepad = PadlistNAMES(padlist);
2286     }
2287
2288     if (paren)
2289         sv_catpvs_nomg(out, "(");
2290     for (i = 0; i < n; i++) {
2291         if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2292         {
2293             STRLEN cur = SvCUR(out);
2294             Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2295                                  UTF8fARG(1, PadnameLEN(sv) - 1,
2296                                           PadnamePV(sv) + 1));
2297             if (is_scalar)
2298                 SvPVX(out)[cur] = '$';
2299         }
2300         else
2301             Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2302         if (i < n - 1)
2303             sv_catpvs_nomg(out, ",");
2304     }
2305     if (paren)
2306         sv_catpvs_nomg(out, "(");
2307 }
2308
2309
2310 static void
2311 S_append_gv_name(pTHX_ GV *gv, SV *out)
2312 {
2313     SV *sv;
2314     if (!gv) {
2315         sv_catpvs_nomg(out, "<NULLGV>");
2316         return;
2317     }
2318     sv = newSV(0);
2319     gv_fullname4(sv, gv, NULL, FALSE);
2320     Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv));
2321     SvREFCNT_dec_NN(sv);
2322 }
2323
2324 #ifdef USE_ITHREADS
2325 #  define ITEM_SV(item) (comppad ? \
2326     *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2327 #else
2328 #  define ITEM_SV(item) UNOP_AUX_item_sv(item)
2329 #endif
2330
2331
2332 /* return a temporary SV containing a stringified representation of
2333  * the op_aux field of a MULTIDEREF op, associated with CV cv
2334  */
2335
2336 SV*
2337 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2338 {
2339     UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2340     UV actions = items->uv;
2341     SV *sv;
2342     bool last = 0;
2343     bool is_hash = FALSE;
2344     int derefs = 0;
2345     SV *out = newSVpvn_flags("",0,SVs_TEMP);
2346 #ifdef USE_ITHREADS
2347     PAD *comppad;
2348
2349     if (cv) {
2350         PADLIST *padlist = CvPADLIST(cv);
2351         comppad = PadlistARRAY(padlist)[1];
2352     }
2353     else
2354         comppad = NULL;
2355 #endif
2356
2357     PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2358
2359     while (!last) {
2360         switch (actions & MDEREF_ACTION_MASK) {
2361
2362         case MDEREF_reload:
2363             actions = (++items)->uv;
2364             continue;
2365             NOT_REACHED; /* NOTREACHED */
2366
2367         case MDEREF_HV_padhv_helem:
2368             is_hash = TRUE;
2369             /* FALLTHROUGH */
2370         case MDEREF_AV_padav_aelem:
2371             derefs = 1;
2372             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2373             goto do_elem;
2374             NOT_REACHED; /* NOTREACHED */
2375
2376         case MDEREF_HV_gvhv_helem:
2377             is_hash = TRUE;
2378             /* FALLTHROUGH */
2379         case MDEREF_AV_gvav_aelem:
2380             derefs = 1;
2381             items++;
2382             sv = ITEM_SV(items);
2383             S_append_gv_name(aTHX_ (GV*)sv, out);
2384             goto do_elem;
2385             NOT_REACHED; /* NOTREACHED */
2386
2387         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2388             is_hash = TRUE;
2389             /* FALLTHROUGH */
2390         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2391             items++;
2392             sv = ITEM_SV(items);
2393             S_append_gv_name(aTHX_ (GV*)sv, out);
2394             goto do_vivify_rv2xv_elem;
2395             NOT_REACHED; /* NOTREACHED */
2396
2397         case MDEREF_HV_padsv_vivify_rv2hv_helem:
2398             is_hash = TRUE;
2399             /* FALLTHROUGH */
2400         case MDEREF_AV_padsv_vivify_rv2av_aelem:
2401             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2402             goto do_vivify_rv2xv_elem;
2403             NOT_REACHED; /* NOTREACHED */
2404
2405         case MDEREF_HV_pop_rv2hv_helem:
2406         case MDEREF_HV_vivify_rv2hv_helem:
2407             is_hash = TRUE;
2408             /* FALLTHROUGH */
2409         do_vivify_rv2xv_elem:
2410         case MDEREF_AV_pop_rv2av_aelem:
2411         case MDEREF_AV_vivify_rv2av_aelem:
2412             if (!derefs++)
2413                 sv_catpvs_nomg(out, "->");
2414         do_elem:
2415             if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2416                 sv_catpvs_nomg(out, "->");
2417                 last = 1;
2418                 break;
2419             }
2420
2421             sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2422             switch (actions & MDEREF_INDEX_MASK) {
2423             case MDEREF_INDEX_const:
2424                 if (is_hash) {
2425                     items++;
2426                     sv = ITEM_SV(items);
2427                     if (!sv)
2428                         sv_catpvs_nomg(out, "???");
2429                     else {
2430                         STRLEN cur;
2431                         char *s;
2432                         s = SvPV(sv, cur);
2433                         pv_pretty(out, s, cur, 30,
2434                                     NULL, NULL,
2435                                     (PERL_PV_PRETTY_NOCLEAR
2436                                     |PERL_PV_PRETTY_QUOTE
2437                                     |PERL_PV_PRETTY_ELLIPSES));
2438                     }
2439                 }
2440                 else
2441                     Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2442                 break;
2443             case MDEREF_INDEX_padsv:
2444                 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2445                 break;
2446             case MDEREF_INDEX_gvsv:
2447                 items++;
2448                 sv = ITEM_SV(items);
2449                 S_append_gv_name(aTHX_ (GV*)sv, out);
2450                 break;
2451             }
2452             sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2453
2454             if (actions & MDEREF_FLAG_last)
2455                 last = 1;
2456             is_hash = FALSE;
2457
2458             break;
2459
2460         default:
2461             PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2462                 (int)(actions & MDEREF_ACTION_MASK));
2463             last = 1;
2464             break;
2465
2466         } /* switch */
2467
2468         actions >>= MDEREF_SHIFT;
2469     } /* while */
2470     return out;
2471 }
2472
2473
2474 I32
2475 Perl_debop(pTHX_ const OP *o)
2476 {
2477     PERL_ARGS_ASSERT_DEBOP;
2478
2479     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2480         return 0;
2481
2482     Perl_deb(aTHX_ "%s", OP_NAME(o));
2483     switch (o->op_type) {
2484     case OP_CONST:
2485     case OP_HINTSEVAL:
2486         /* With ITHREADS, consts are stored in the pad, and the right pad
2487          * may not be active here, so check.
2488          * Looks like only during compiling the pads are illegal.
2489          */
2490 #ifdef USE_ITHREADS
2491         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2492 #endif
2493             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2494         break;
2495     case OP_GVSV:
2496     case OP_GV:
2497         if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2498             SV * const sv = newSV(0);
2499             gv_fullname3(sv, cGVOPo_gv, NULL);
2500             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2501             SvREFCNT_dec_NN(sv);
2502         }
2503         else if (cGVOPo_gv) {
2504             SV * const sv = newSV(0);
2505             assert(SvROK(cGVOPo_gv));
2506             assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2507             PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2508                     SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2509             SvREFCNT_dec_NN(sv);
2510         }
2511         else
2512             PerlIO_printf(Perl_debug_log, "(NULL)");
2513         break;
2514
2515     case OP_PADSV:
2516     case OP_PADAV:
2517     case OP_PADHV:
2518         S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2519         break;
2520
2521     case OP_PADRANGE:
2522         S_deb_padvar(aTHX_ o->op_targ,
2523                         o->op_private & OPpPADRANGE_COUNTMASK, 1);
2524         break;
2525
2526     case OP_MULTIDEREF:
2527         PerlIO_printf(Perl_debug_log, "(%"SVf")",
2528             SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2529         break;
2530
2531     default:
2532         break;
2533     }
2534     PerlIO_printf(Perl_debug_log, "\n");
2535     return 0;
2536 }
2537
2538 STATIC CV*
2539 S_deb_curcv(pTHX_ I32 ix)
2540 {
2541     PERL_SI *si = PL_curstackinfo;
2542     for (; ix >=0; ix--) {
2543         const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2544
2545         if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2546             return cx->blk_sub.cv;
2547         else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2548             return cx->blk_eval.cv;
2549         else if (ix == 0 && si->si_type == PERLSI_MAIN)
2550             return PL_main_cv;
2551         else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2552                && si->si_type == PERLSI_SORT)
2553         {
2554             /* fake sort sub; use CV of caller */
2555             si = si->si_prev;
2556             ix = si->si_cxix + 1;
2557         }
2558     }
2559     return NULL;
2560 }
2561
2562 void
2563 Perl_watch(pTHX_ char **addr)
2564 {
2565     PERL_ARGS_ASSERT_WATCH;
2566
2567     PL_watchaddr = addr;
2568     PL_watchok = *addr;
2569     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2570         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2571 }
2572
2573 STATIC void
2574 S_debprof(pTHX_ const OP *o)
2575 {
2576     PERL_ARGS_ASSERT_DEBPROF;
2577
2578     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2579         return;
2580     if (!PL_profiledata)
2581         Newxz(PL_profiledata, MAXO, U32);
2582     ++PL_profiledata[o->op_type];
2583 }
2584
2585 void
2586 Perl_debprofdump(pTHX)
2587 {
2588     unsigned i;
2589     if (!PL_profiledata)
2590         return;
2591     for (i = 0; i < MAXO; i++) {
2592         if (PL_profiledata[i])
2593             PerlIO_printf(Perl_debug_log,
2594                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2595                                        PL_op_name[i]);
2596     }
2597 }
2598
2599
2600 /*
2601  * ex: set ts=8 sts=4 sw=4 et:
2602  */