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