This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add PL_sv_zero
[perl5.git] / dump.c
1 /*    dump.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *  'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13  *   it has not been hard for me to read your mind and memory.'
14  *
15  *     [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
16  */
17
18 /* This file contains utility routines to dump the contents of SV and OP
19  * structures, as used by command-line options like -Dt and -Dx, and
20  * by Devel::Peek.
21  *
22  * It also holds the debugging version of the  runops function.
23
24 =head1 Display and Dump functions
25  */
26
27 #include "EXTERN.h"
28 #define PERL_IN_DUMP_C
29 #include "perl.h"
30 #include "regcomp.h"
31
32 static const char* const svtypenames[SVt_LAST] = {
33     "NULL",
34     "IV",
35     "NV",
36     "PV",
37     "INVLIST",
38     "PVIV",
39     "PVNV",
40     "PVMG",
41     "REGEXP",
42     "PVGV",
43     "PVLV",
44     "PVAV",
45     "PVHV",
46     "PVCV",
47     "PVFM",
48     "PVIO"
49 };
50
51
52 static const char* const svshorttypenames[SVt_LAST] = {
53     "UNDEF",
54     "IV",
55     "NV",
56     "PV",
57     "INVLST",
58     "PVIV",
59     "PVNV",
60     "PVMG",
61     "REGEXP",
62     "GV",
63     "PVLV",
64     "AV",
65     "HV",
66     "CV",
67     "FM",
68     "IO"
69 };
70
71 struct flag_to_name {
72     U32 flag;
73     const char *name;
74 };
75
76 static void
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78                const struct flag_to_name *const end)
79 {
80     do {
81         if (flags & start->flag)
82             sv_catpv(sv, start->name);
83     } while (++start < end);
84 }
85
86 #define append_flags(sv, f, flags) \
87     S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
88
89 #define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
90                               (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
91                               PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
92                               | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
93
94 /*
95 =for apidoc pv_escape
96
97 Escapes at most the first C<count> chars of C<pv> and puts the results into
98 C<dsv> such that the size of the escaped string will not exceed C<max> chars
99 and will not contain any incomplete escape sequences.  The number of bytes
100 escaped will be returned in the C<STRLEN *escaped> parameter if it is not null.
101 When the C<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 C<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 C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur.
109
110 If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8
111 if C<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 C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output
115 using C<\x01F1> style escapes, otherwise if C<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 C<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 C<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 C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a C<"%"> and
130 not a C<"\\">.  This is because regexes very often contain backslashed
131 sequences, whereas C<"%"> is not a particularly common character in patterns.
132
133 Returns a pointer to the escaped text as held by C<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             SvPVCLEAR(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 C<pv_escape()> and supporting quoting and ellipses.
253
254 If the C<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 C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
257 angle brackets. 
258
259 If the C<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 C<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 C<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 C<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         SvPVCLEAR(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     SvPVCLEAR(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
373             || sv == &PL_sv_zero || sv == &PL_sv_placeholder)
374     {
375         if (sv == &PL_sv_undef) {
376             sv_catpv(t, "SV_UNDEF");
377             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
378                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
379                 SvREADONLY(sv))
380                 goto finish;
381         }
382         else if (sv == &PL_sv_no) {
383             sv_catpv(t, "SV_NO");
384             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
385                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
386                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
387                                   SVp_POK|SVp_NOK)) &&
388                 SvCUR(sv) == 0 &&
389                 SvNVX(sv) == 0.0)
390                 goto finish;
391         }
392         else if (sv == &PL_sv_yes) {
393             sv_catpv(t, "SV_YES");
394             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
395                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
396                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
397                                   SVp_POK|SVp_NOK)) &&
398                 SvCUR(sv) == 1 &&
399                 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
400                 SvNVX(sv) == 1.0)
401                 goto finish;
402         }
403         else if (sv == &PL_sv_zero) {
404             sv_catpv(t, "SV_ZERO");
405             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
406                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
407                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
408                                   SVp_POK|SVp_NOK)) &&
409                 SvCUR(sv) == 1 &&
410                 SvPVX_const(sv) && *SvPVX_const(sv) == '0' &&
411                 SvNVX(sv) == 0.0)
412                 goto finish;
413         }
414         else {
415             sv_catpv(t, "SV_PLACEHOLDER");
416             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
417                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
418                 SvREADONLY(sv))
419                 goto finish;
420         }
421         sv_catpv(t, ":");
422     }
423     else if (SvREFCNT(sv) == 0) {
424         sv_catpv(t, "(");
425         unref++;
426     }
427     else if (DEBUG_R_TEST_) {
428         int is_tmp = 0;
429         SSize_t ix;
430         /* is this SV on the tmps stack? */
431         for (ix=PL_tmps_ix; ix>=0; ix--) {
432             if (PL_tmps_stack[ix] == sv) {
433                 is_tmp = 1;
434                 break;
435             }
436         }
437         if (is_tmp || SvREFCNT(sv) > 1) {
438             Perl_sv_catpvf(aTHX_ t, "<");
439             if (SvREFCNT(sv) > 1)
440                 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv));
441             if (is_tmp)
442                 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
443             Perl_sv_catpvf(aTHX_ t, ">");
444         }
445     }
446
447     if (SvROK(sv)) {
448         sv_catpv(t, "\\");
449         if (SvCUR(t) + unref > 10) {
450             SvCUR_set(t, unref + 3);
451             *SvEND(t) = '\0';
452             sv_catpv(t, "...");
453             goto finish;
454         }
455         sv = SvRV(sv);
456         goto retry;
457     }
458     type = SvTYPE(sv);
459     if (type == SVt_PVCV) {
460         SV * const tmp = newSVpvs_flags("", SVs_TEMP);
461         GV* gvcv = CvGV(sv);
462         Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
463                        ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
464                        : "");
465         goto finish;
466     } else if (type < SVt_LAST) {
467         sv_catpv(t, svshorttypenames[type]);
468
469         if (type == SVt_NULL)
470             goto finish;
471     } else {
472         sv_catpv(t, "FREED");
473         goto finish;
474     }
475
476     if (SvPOKp(sv)) {
477         if (!SvPVX_const(sv))
478             sv_catpv(t, "(null)");
479         else {
480             SV * const tmp = newSVpvs("");
481             sv_catpv(t, "(");
482             if (SvOOK(sv)) {
483                 STRLEN delta;
484                 SvOOK_offset(sv, delta);
485                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
486             }
487             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
488             if (SvUTF8(sv))
489                 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
490                                sv_uni_display(tmp, sv, 6 * SvCUR(sv),
491                                               UNI_DISPLAY_QQ));
492             SvREFCNT_dec_NN(tmp);
493         }
494     }
495     else if (SvNOKp(sv)) {
496         STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
497         Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv));
498         RESTORE_LC_NUMERIC_UNDERLYING();
499     }
500     else if (SvIOKp(sv)) {
501         if (SvIsUV(sv))
502             Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
503         else
504             Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv));
505     }
506     else
507         sv_catpv(t, "()");
508
509   finish:
510     while (unref--)
511         sv_catpv(t, ")");
512     if (TAINTING_get && sv && SvTAINTED(sv))
513         sv_catpv(t, " [tainted]");
514     return SvPV_nolen(t);
515 }
516
517 /*
518 =head1 Debugging Utilities
519 */
520
521 void
522 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
523 {
524     va_list args;
525     PERL_ARGS_ASSERT_DUMP_INDENT;
526     va_start(args, pat);
527     dump_vindent(level, file, pat, &args);
528     va_end(args);
529 }
530
531 void
532 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
533 {
534     PERL_ARGS_ASSERT_DUMP_VINDENT;
535     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
536     PerlIO_vprintf(file, pat, *args);
537 }
538
539
540 /* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar
541  * for each indent level as appropriate.
542  *
543  * bar contains bits indicating which indent columns should have a
544  * vertical bar displayed. Bit 0 is the RH-most column. If there are more
545  * levels than bits in bar, then the first few indents are displayed
546  * without a bar.
547  *
548  * The start of a new op is signalled by passing a value for level which
549  * has been negated and offset by 1 (so that level 0 is passed as -1 and
550  * can thus be distinguished from -0); in this case, emit a suitably
551  * indented blank line, then on the next line, display the op's sequence
552  * number, and make the final indent an '+----'.
553  *
554  * e.g.
555  *
556  *      |   FOO       # level = 1,   bar = 0b1
557  *      |   |         # level =-2-1, bar = 0b11
558  * 1234 |   +---BAR
559  *      |       BAZ   # level = 2,   bar = 0b10
560  */
561
562 static void
563 S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
564                 const char* pat, ...)
565 {
566     va_list args;
567     I32 i;
568     bool newop = (level < 0);
569
570     va_start(args, pat);
571
572     /* start displaying a new op? */
573     if (newop) {
574         UV seq = sequence_num(o);
575
576         level = -level - 1;
577
578         /* output preceding blank line */
579         PerlIO_puts(file, "     ");
580         for (i = level-1; i >= 0; i--)
581             PerlIO_puts(file,  i == 0 || (bar & (1 << i)) ?  "|   " : "    ");
582         PerlIO_puts(file, "\n");
583
584         /* output sequence number */
585         if (seq)
586             PerlIO_printf(file, "%-4" UVuf " ", seq);
587         else
588             PerlIO_puts(file, "???? ");
589
590     }
591     else
592         PerlIO_printf(file, "     ");
593
594     for (i = level-1; i >= 0; i--)
595             PerlIO_puts(file,
596                   (i == 0 && newop) ? "+--"
597                 : (bar & (1 << i))  ? "|   "
598                 :                     "    ");
599     PerlIO_vprintf(file, pat, args);
600     va_end(args);
601 }
602
603
604 /* display a link field (e.g. op_next) in the format
605  *     ====> sequence_number [opname 0x123456]
606  */
607
608 static void
609 S_opdump_link(pTHX_ const OP *o, PerlIO *file)
610 {
611     PerlIO_puts(file, " ===> ");
612     if (o)
613         PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
614             sequence_num(o), OP_NAME(o), PTR2UV(o));
615     else
616         PerlIO_puts(file, "[0x0]\n");
617 }
618
619 /*
620 =for apidoc dump_all
621
622 Dumps the entire optree of the current program starting at C<PL_main_root> to 
623 C<STDERR>.  Also dumps the optrees for all visible subroutines in
624 C<PL_defstash>.
625
626 =cut
627 */
628
629 void
630 Perl_dump_all(pTHX)
631 {
632     dump_all_perl(FALSE);
633 }
634
635 void
636 Perl_dump_all_perl(pTHX_ bool justperl)
637 {
638     PerlIO_setlinebuf(Perl_debug_log);
639     if (PL_main_root)
640         op_dump(PL_main_root);
641     dump_packsubs_perl(PL_defstash, justperl);
642 }
643
644 /*
645 =for apidoc dump_packsubs
646
647 Dumps the optrees for all visible subroutines in C<stash>.
648
649 =cut
650 */
651
652 void
653 Perl_dump_packsubs(pTHX_ const HV *stash)
654 {
655     PERL_ARGS_ASSERT_DUMP_PACKSUBS;
656     dump_packsubs_perl(stash, FALSE);
657 }
658
659 void
660 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
661 {
662     I32 i;
663
664     PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
665
666     if (!HvARRAY(stash))
667         return;
668     for (i = 0; i <= (I32) HvMAX(stash); i++) {
669         const HE *entry;
670         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
671             GV * gv = (GV *)HeVAL(entry);
672             if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
673                 /* unfake a fake GV */
674                 (void)CvGV(SvRV(gv));
675             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
676                 continue;
677             if (GvCVu(gv))
678                 dump_sub_perl(gv, justperl);
679             if (GvFORM(gv))
680                 dump_form(gv);
681             if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
682                 const HV * const hv = GvHV(gv);
683                 if (hv && (hv != PL_defstash))
684                     dump_packsubs_perl(hv, justperl); /* nested package */
685             }
686         }
687     }
688 }
689
690 void
691 Perl_dump_sub(pTHX_ const GV *gv)
692 {
693     PERL_ARGS_ASSERT_DUMP_SUB;
694     dump_sub_perl(gv, FALSE);
695 }
696
697 void
698 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
699 {
700     CV *cv;
701
702     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
703
704     cv = isGV_with_GP(gv) ? GvCV(gv) :
705             (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
706     if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
707         return;
708
709     if (isGV_with_GP(gv)) {
710         SV * const namesv = newSVpvs_flags("", SVs_TEMP);
711         SV *escsv = newSVpvs_flags("", SVs_TEMP);
712         const char *namepv;
713         STRLEN namelen;
714         gv_fullname3(namesv, gv, NULL);
715         namepv = SvPV_const(namesv, namelen);
716         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
717                      generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
718     } else {
719         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
720     }
721     if (CvISXSUB(cv))
722         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
723             PTR2UV(CvXSUB(cv)),
724             (int)CvXSUBANY(cv).any_i32);
725     else if (CvROOT(cv))
726         op_dump(CvROOT(cv));
727     else
728         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
729 }
730
731 void
732 Perl_dump_form(pTHX_ const GV *gv)
733 {
734     SV * const sv = sv_newmortal();
735
736     PERL_ARGS_ASSERT_DUMP_FORM;
737
738     gv_fullname3(sv, gv, NULL);
739     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
740     if (CvROOT(GvFORM(gv)))
741         op_dump(CvROOT(GvFORM(gv)));
742     else
743         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
744 }
745
746 void
747 Perl_dump_eval(pTHX)
748 {
749     op_dump(PL_eval_root);
750 }
751
752
753 /* returns a temp SV displaying the name of a GV. Handles the case where
754  * a GV is in fact a ref to a CV */
755
756 static SV *
757 S_gv_display(pTHX_ GV *gv)
758 {
759     SV * const name = newSVpvs_flags("", SVs_TEMP);
760     if (gv) {
761         SV * const raw = newSVpvs_flags("", SVs_TEMP);
762         STRLEN len;
763         const char * rawpv;
764
765         if (isGV_with_GP(gv))
766             gv_fullname3(raw, gv, NULL);
767         else {
768             assert(SvROK(gv));
769             assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
770             Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
771                     SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
772         }
773         rawpv = SvPV_const(raw, len);
774         generic_pv_escape(name, rawpv, len, SvUTF8(raw));
775     }
776     else
777         sv_catpvs(name, "(NULL)");
778
779     return name;
780 }
781
782
783
784 /* forward decl */
785 static void
786 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
787
788
789 static void
790 S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
791 {
792     UV kidbar;
793
794     if (!pm)
795         return;
796
797     kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
798
799     if (PM_GETRE(pm)) {
800         char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
801         S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
802              ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
803     }
804     else
805         S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
806
807     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
808         SV * const tmpsv = pm_description(pm);
809         S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
810                         SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
811         SvREFCNT_dec_NN(tmpsv);
812     }
813
814     if (pm->op_type == OP_SPLIT)
815         S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
816                     "TARGOFF/GV = 0x%" UVxf "\n",
817                     PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
818     else {
819         if (pm->op_pmreplrootu.op_pmreplroot) {
820             S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
821             S_do_op_dump_bar(aTHX_ level + 2,
822                 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
823                 file, pm->op_pmreplrootu.op_pmreplroot);
824         }
825     }
826
827     if (pm->op_code_list) {
828         if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
829             S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
830             S_do_op_dump_bar(aTHX_ level + 2,
831                             (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
832                             file, pm->op_code_list);
833         }
834         else
835             S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
836                         "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
837     }
838 }
839
840
841 void
842 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
843 {
844     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
845     S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
846 }
847
848
849 const struct flag_to_name pmflags_flags_names[] = {
850     {PMf_CONST, ",CONST"},
851     {PMf_KEEP, ",KEEP"},
852     {PMf_GLOBAL, ",GLOBAL"},
853     {PMf_CONTINUE, ",CONTINUE"},
854     {PMf_RETAINT, ",RETAINT"},
855     {PMf_EVAL, ",EVAL"},
856     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
857     {PMf_HAS_CV, ",HAS_CV"},
858     {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
859     {PMf_IS_QR, ",IS_QR"}
860 };
861
862 static SV *
863 S_pm_description(pTHX_ const PMOP *pm)
864 {
865     SV * const desc = newSVpvs("");
866     const REGEXP * const regex = PM_GETRE(pm);
867     const U32 pmflags = pm->op_pmflags;
868
869     PERL_ARGS_ASSERT_PM_DESCRIPTION;
870
871     if (pmflags & PMf_ONCE)
872         sv_catpv(desc, ",ONCE");
873 #ifdef USE_ITHREADS
874     if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
875         sv_catpv(desc, ":USED");
876 #else
877     if (pmflags & PMf_USED)
878         sv_catpv(desc, ":USED");
879 #endif
880
881     if (regex) {
882         if (RX_ISTAINTED(regex))
883             sv_catpv(desc, ",TAINTED");
884         if (RX_CHECK_SUBSTR(regex)) {
885             if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
886                 sv_catpv(desc, ",SCANFIRST");
887             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
888                 sv_catpv(desc, ",ALL");
889         }
890         if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
891             sv_catpv(desc, ",SKIPWHITE");
892     }
893
894     append_flags(desc, pmflags, pmflags_flags_names);
895     return desc;
896 }
897
898 void
899 Perl_pmop_dump(pTHX_ PMOP *pm)
900 {
901     do_pmop_dump(0, Perl_debug_log, pm);
902 }
903
904 /* Return a unique integer to represent the address of op o.
905  * If it already exists in PL_op_sequence, just return it;
906  * otherwise add it.
907  *  *** Note that this isn't thread-safe */
908
909 STATIC UV
910 S_sequence_num(pTHX_ const OP *o)
911 {
912     dVAR;
913     SV     *op,
914           **seq;
915     const char *key;
916     STRLEN  len;
917     if (!o)
918         return 0;
919     op = newSVuv(PTR2UV(o));
920     sv_2mortal(op);
921     key = SvPV_const(op, len);
922     if (!PL_op_sequence)
923         PL_op_sequence = newHV();
924     seq = hv_fetch(PL_op_sequence, key, len, 0);
925     if (seq)
926         return SvUV(*seq);
927     (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
928     return PL_op_seq;
929 }
930
931
932
933
934
935 const struct flag_to_name op_flags_names[] = {
936     {OPf_KIDS, ",KIDS"},
937     {OPf_PARENS, ",PARENS"},
938     {OPf_REF, ",REF"},
939     {OPf_MOD, ",MOD"},
940     {OPf_STACKED, ",STACKED"},
941     {OPf_SPECIAL, ",SPECIAL"}
942 };
943
944
945 /* indexed by enum OPclass */
946 const char * const op_class_names[] = {
947     "NULL",
948     "OP",
949     "UNOP",
950     "BINOP",
951     "LOGOP",
952     "LISTOP",
953     "PMOP",
954     "SVOP",
955     "PADOP",
956     "PVOP",
957     "LOOP",
958     "COP",
959     "METHOP",
960     "UNOP_AUX",
961 };
962
963
964 /* dump an op and any children. level indicates the initial indent.
965  * The bits of bar indicate which indents should receive a vertical bar.
966  * For example if level == 5 and bar == 0b01101, then the indent prefix
967  * emitted will be (not including the <>'s):
968  *
969  *   <    |   |       |   >
970  *    55554444333322221111
971  *
972  * For heavily nested output, the level may exceed the number of bits
973  * in bar; in this case the first few columns in the output will simply
974  * not have a bar, which is harmless.
975  */
976
977 static void
978 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
979 {
980     const OPCODE optype = o->op_type;
981
982     PERL_ARGS_ASSERT_DO_OP_DUMP;
983
984     /* print op header line */
985
986     S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
987
988     if (optype == OP_NULL && o->op_targ)
989         PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
990
991     PerlIO_printf(file, " %s(0x%" UVxf ")",
992                     op_class_names[op_class(o)], PTR2UV(o));
993     S_opdump_link(aTHX_ o->op_next, file);
994
995     /* print op common fields */
996
997     if (o->op_targ && optype != OP_NULL)
998             S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
999                 (long)o->op_targ);
1000
1001     if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
1002         SV * const tmpsv = newSVpvs("");
1003         switch (o->op_flags & OPf_WANT) {
1004         case OPf_WANT_VOID:
1005             sv_catpv(tmpsv, ",VOID");
1006             break;
1007         case OPf_WANT_SCALAR:
1008             sv_catpv(tmpsv, ",SCALAR");
1009             break;
1010         case OPf_WANT_LIST:
1011             sv_catpv(tmpsv, ",LIST");
1012             break;
1013         default:
1014             sv_catpv(tmpsv, ",UNKNOWN");
1015             break;
1016         }
1017         append_flags(tmpsv, o->op_flags, op_flags_names);
1018         if (o->op_slabbed)  sv_catpvs(tmpsv, ",SLABBED");
1019         if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
1020         if (o->op_static)   sv_catpvs(tmpsv, ",STATIC");
1021         if (o->op_folded)   sv_catpvs(tmpsv, ",FOLDED");
1022         if (o->op_moresib)  sv_catpvs(tmpsv, ",MORESIB");
1023         S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
1024                          SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1025     }
1026
1027     if (o->op_private) {
1028         U16 oppriv = o->op_private;
1029         I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
1030         SV * tmpsv = NULL;
1031
1032         if (op_ix != -1) {
1033             U16 stop = 0;
1034             tmpsv = newSVpvs("");
1035             for (; !stop; op_ix++) {
1036                 U16 entry = PL_op_private_bitdefs[op_ix];
1037                 U16 bit = (entry >> 2) & 7;
1038                 U16 ix = entry >> 5;
1039
1040                 stop = (entry & 1);
1041
1042                 if (entry & 2) {
1043                     /* bitfield */
1044                     I16 const *p = &PL_op_private_bitfields[ix];
1045                     U16 bitmin = (U16) *p++;
1046                     I16 label = *p++;
1047                     I16 enum_label;
1048                     U16 mask = 0;
1049                     U16 i;
1050                     U16 val;
1051
1052                     for (i = bitmin; i<= bit; i++)
1053                         mask |= (1<<i);
1054                     bit = bitmin;
1055                     val = (oppriv & mask);
1056
1057                     if (   label != -1
1058                         && PL_op_private_labels[label] == '-'
1059                         && PL_op_private_labels[label+1] == '\0'
1060                     )
1061                         /* display as raw number */
1062                         continue;
1063
1064                     oppriv -= val;
1065                     val >>= bit;
1066                     enum_label = -1;
1067                     while (*p != -1) {
1068                         if (val == *p++) {
1069                             enum_label = *p;
1070                             break;
1071                         }
1072                         p++;
1073                     }
1074                     if (val == 0 && enum_label == -1)
1075                         /* don't display anonymous zero values */
1076                         continue;
1077
1078                     sv_catpv(tmpsv, ",");
1079                     if (label != -1) {
1080                         sv_catpv(tmpsv, &PL_op_private_labels[label]);
1081                         sv_catpv(tmpsv, "=");
1082                     }
1083                     if (enum_label == -1)
1084                         Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
1085                     else
1086                         sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
1087
1088                 }
1089                 else {
1090                     /* bit flag */
1091                     if (   oppriv & (1<<bit)
1092                         && !(PL_op_private_labels[ix] == '-'
1093                              && PL_op_private_labels[ix+1] == '\0'))
1094                     {
1095                         oppriv -= (1<<bit);
1096                         sv_catpv(tmpsv, ",");
1097                         sv_catpv(tmpsv, &PL_op_private_labels[ix]);
1098                     }
1099                 }
1100             }
1101             if (oppriv) {
1102                 sv_catpv(tmpsv, ",");
1103                 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
1104             }
1105         }
1106         if (tmpsv && SvCUR(tmpsv)) {
1107             S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
1108                             SvPVX_const(tmpsv) + 1);
1109         } else
1110             S_opdump_indent(aTHX_ o, level, bar, file,
1111                             "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
1112     }
1113
1114     switch (optype) {
1115     case OP_AELEMFAST:
1116     case OP_GVSV:
1117     case OP_GV:
1118 #ifdef USE_ITHREADS
1119         S_opdump_indent(aTHX_ o, level, bar, file,
1120                         "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1121 #else
1122         S_opdump_indent(aTHX_ o, level, bar, file,
1123             "GV = %" SVf " (0x%" UVxf ")\n",
1124             SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
1125 #endif
1126         break;
1127
1128     case OP_MULTIDEREF:
1129     {
1130         UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1131         UV i, count = items[-1].uv;
1132
1133         S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
1134         for (i=0; i < count;  i++)
1135             S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1136                                     "%" UVuf " => 0x%" UVxf "\n",
1137                                     i, items[i].uv);
1138         break;
1139     }
1140
1141     case OP_CONST:
1142     case OP_HINTSEVAL:
1143     case OP_METHOD_NAMED:
1144     case OP_METHOD_SUPER:
1145     case OP_METHOD_REDIR:
1146     case OP_METHOD_REDIR_SUPER:
1147 #ifndef USE_ITHREADS
1148         /* with ITHREADS, consts are stored in the pad, and the right pad
1149          * may not be active here, so skip */
1150         S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
1151                         SvPEEK(cMETHOPx_meth(o)));
1152 #endif
1153         break;
1154     case OP_NULL:
1155         if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1156             break;
1157         /* FALLTHROUGH */
1158     case OP_NEXTSTATE:
1159     case OP_DBSTATE:
1160         if (CopLINE(cCOPo))
1161             S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
1162                              (UV)CopLINE(cCOPo));
1163
1164         if (CopSTASHPV(cCOPo)) {
1165             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1166             HV *stash = CopSTASH(cCOPo);
1167             const char * const hvname = HvNAME_get(stash);
1168
1169             S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
1170                                generic_pv_escape(tmpsv, hvname,
1171                                   HvNAMELEN(stash), HvNAMEUTF8(stash)));
1172         }
1173
1174         if (CopLABEL(cCOPo)) {
1175             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1176             STRLEN label_len;
1177             U32 label_flags;
1178             const char *label = CopLABEL_len_flags(cCOPo,
1179                                                      &label_len, &label_flags);
1180             S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1181                                 generic_pv_escape( tmpsv, label, label_len,
1182                                            (label_flags & SVf_UTF8)));
1183         }
1184
1185         S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
1186                          (unsigned int)cCOPo->cop_seq);
1187         break;
1188
1189     case OP_ENTERITER:
1190     case OP_ENTERLOOP:
1191         S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
1192         S_opdump_link(aTHX_ cLOOPo->op_redoop, file);
1193         S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
1194         S_opdump_link(aTHX_ cLOOPo->op_nextop, file);
1195         S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
1196         S_opdump_link(aTHX_ cLOOPo->op_lastop, file);
1197         break;
1198
1199     case OP_REGCOMP:
1200     case OP_SUBSTCONT:
1201     case OP_COND_EXPR:
1202     case OP_RANGE:
1203     case OP_MAPWHILE:
1204     case OP_GREPWHILE:
1205     case OP_OR:
1206     case OP_DOR:
1207     case OP_AND:
1208     case OP_ORASSIGN:
1209     case OP_DORASSIGN:
1210     case OP_ANDASSIGN:
1211     case OP_ARGDEFELEM:
1212     case OP_ENTERGIVEN:
1213     case OP_ENTERWHEN:
1214     case OP_ENTERTRY:
1215     case OP_ONCE:
1216         S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
1217         S_opdump_link(aTHX_ cLOGOPo->op_other, file);
1218         break;
1219     case OP_SPLIT:
1220     case OP_MATCH:
1221     case OP_QR:
1222     case OP_SUBST:
1223         S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
1224         break;
1225     case OP_LEAVE:
1226     case OP_LEAVEEVAL:
1227     case OP_LEAVESUB:
1228     case OP_LEAVESUBLV:
1229     case OP_LEAVEWRITE:
1230     case OP_SCOPE:
1231         if (o->op_private & OPpREFCOUNTED)
1232             S_opdump_indent(aTHX_ o, level, bar, file,
1233                             "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1234         break;
1235
1236     case OP_DUMP:
1237     case OP_GOTO:
1238     case OP_NEXT:
1239     case OP_LAST:
1240     case OP_REDO:
1241         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1242             break;
1243         {
1244             SV * const label = newSVpvs_flags("", SVs_TEMP);
1245             generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
1246             S_opdump_indent(aTHX_ o, level, bar, file,
1247                             "PV = \"%" SVf "\" (0x%" UVxf ")\n",
1248                             SVfARG(label), PTR2UV(cPVOPo->op_pv));
1249             break;
1250         }
1251
1252     case OP_TRANS:
1253     case OP_TRANSR:
1254             S_opdump_indent(aTHX_ o, level, bar, file,
1255                             "PV = 0x%" UVxf "\n",
1256                             PTR2UV(cPVOPo->op_pv));
1257             break;
1258
1259
1260     default:
1261         break;
1262     }
1263     if (o->op_flags & OPf_KIDS) {
1264         OP *kid;
1265         level++;
1266         bar <<= 1;
1267         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1268             S_do_op_dump_bar(aTHX_ level,
1269                             (bar | cBOOL(OpHAS_SIBLING(kid))),
1270                             file, kid);
1271     }
1272 }
1273
1274
1275 void
1276 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1277 {
1278     S_do_op_dump_bar(aTHX_ level, 0, file, o);
1279 }
1280
1281
1282 /*
1283 =for apidoc op_dump
1284
1285 Dumps the optree starting at OP C<o> to C<STDERR>.
1286
1287 =cut
1288 */
1289
1290 void
1291 Perl_op_dump(pTHX_ const OP *o)
1292 {
1293     PERL_ARGS_ASSERT_OP_DUMP;
1294     do_op_dump(0, Perl_debug_log, o);
1295 }
1296
1297 void
1298 Perl_gv_dump(pTHX_ GV *gv)
1299 {
1300     STRLEN len;
1301     const char* name;
1302     SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1303
1304     if (!gv) {
1305         PerlIO_printf(Perl_debug_log, "{}\n");
1306         return;
1307     }
1308     sv = sv_newmortal();
1309     PerlIO_printf(Perl_debug_log, "{\n");
1310     gv_fullname3(sv, gv, NULL);
1311     name = SvPV_const(sv, len);
1312     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1313                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1314     if (gv != GvEGV(gv)) {
1315         gv_efullname3(sv, GvEGV(gv), NULL);
1316         name = SvPV_const(sv, len);
1317         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1318                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1319     }
1320     (void)PerlIO_putc(Perl_debug_log, '\n');
1321     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1322 }
1323
1324
1325 /* map magic types to the symbolic names
1326  * (with the PERL_MAGIC_ prefixed stripped)
1327  */
1328
1329 static const struct { const char type; const char *name; } magic_names[] = {
1330 #include "mg_names.inc"
1331         /* this null string terminates the list */
1332         { 0,                         NULL },
1333 };
1334
1335 void
1336 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1337 {
1338     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1339
1340     for (; mg; mg = mg->mg_moremagic) {
1341         Perl_dump_indent(aTHX_ level, file,
1342                          "  MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
1343         if (mg->mg_virtual) {
1344             const MGVTBL * const v = mg->mg_virtual;
1345             if (v >= PL_magic_vtables
1346                 && v < PL_magic_vtables + magic_vtable_max) {
1347                 const U32 i = v - PL_magic_vtables;
1348                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1349             }
1350             else
1351                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"
1352                                        UVxf "\n", PTR2UV(v));
1353         }
1354         else
1355             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1356
1357         if (mg->mg_private)
1358             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1359
1360         {
1361             int n;
1362             const char *name = NULL;
1363             for (n = 0; magic_names[n].name; n++) {
1364                 if (mg->mg_type == magic_names[n].type) {
1365                     name = magic_names[n].name;
1366                     break;
1367                 }
1368             }
1369             if (name)
1370                 Perl_dump_indent(aTHX_ level, file,
1371                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1372             else
1373                 Perl_dump_indent(aTHX_ level, file,
1374                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1375         }
1376
1377         if (mg->mg_flags) {
1378             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1379             if (mg->mg_type == PERL_MAGIC_envelem &&
1380                 mg->mg_flags & MGf_TAINTEDDIR)
1381                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1382             if (mg->mg_type == PERL_MAGIC_regex_global &&
1383                 mg->mg_flags & MGf_MINMATCH)
1384                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1385             if (mg->mg_flags & MGf_REFCOUNTED)
1386                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1387             if (mg->mg_flags & MGf_GSKIP)
1388                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1389             if (mg->mg_flags & MGf_COPY)
1390                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1391             if (mg->mg_flags & MGf_DUP)
1392                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1393             if (mg->mg_flags & MGf_LOCAL)
1394                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1395             if (mg->mg_type == PERL_MAGIC_regex_global &&
1396                 mg->mg_flags & MGf_BYTES)
1397                 Perl_dump_indent(aTHX_ level, file, "      BYTES\n");
1398         }
1399         if (mg->mg_obj) {
1400             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%" UVxf "\n",
1401                 PTR2UV(mg->mg_obj));
1402             if (mg->mg_type == PERL_MAGIC_qr) {
1403                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1404                 SV * const dsv = sv_newmortal();
1405                 const char * const s
1406                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1407                     60, NULL, NULL,
1408                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1409                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1410                 );
1411                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1412                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %" IVdf "\n",
1413                         (IV)RX_REFCNT(re));
1414             }
1415             if (mg->mg_flags & MGf_REFCOUNTED)
1416                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1417         }
1418         if (mg->mg_len)
1419             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1420         if (mg->mg_ptr) {
1421             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1422             if (mg->mg_len >= 0) {
1423                 if (mg->mg_type != PERL_MAGIC_utf8) {
1424                     SV * const sv = newSVpvs("");
1425                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1426                     SvREFCNT_dec_NN(sv);
1427                 }
1428             }
1429             else if (mg->mg_len == HEf_SVKEY) {
1430                 PerlIO_puts(file, " => HEf_SVKEY\n");
1431                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1432                            maxnest, dumpops, pvlim); /* MG is already +1 */
1433                 continue;
1434             }
1435             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1436             else
1437                 PerlIO_puts(
1438                   file,
1439                  " ???? - " __FILE__
1440                  " does not know how to handle this MG_LEN"
1441                 );
1442             (void)PerlIO_putc(file, '\n');
1443         }
1444         if (mg->mg_type == PERL_MAGIC_utf8) {
1445             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1446             if (cache) {
1447                 IV i;
1448                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1449                     Perl_dump_indent(aTHX_ level, file,
1450                                      "      %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1451                                      i,
1452                                      (UV)cache[i * 2],
1453                                      (UV)cache[i * 2 + 1]);
1454             }
1455         }
1456     }
1457 }
1458
1459 void
1460 Perl_magic_dump(pTHX_ const MAGIC *mg)
1461 {
1462     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1463 }
1464
1465 void
1466 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1467 {
1468     const char *hvname;
1469
1470     PERL_ARGS_ASSERT_DO_HV_DUMP;
1471
1472     Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1473     if (sv && (hvname = HvNAME_get(sv)))
1474     {
1475         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1476            name which quite legally could contain insane things like tabs, newlines, nulls or
1477            other scary crap - this should produce sane results - except maybe for unicode package
1478            names - but we will wait for someone to file a bug on that - demerphq */
1479         SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1480         PerlIO_printf(file, "\t\"%s\"\n",
1481                               generic_pv_escape( tmpsv, hvname,
1482                                    HvNAMELEN(sv), HvNAMEUTF8(sv)));
1483     }
1484     else
1485         (void)PerlIO_putc(file, '\n');
1486 }
1487
1488 void
1489 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1490 {
1491     PERL_ARGS_ASSERT_DO_GV_DUMP;
1492
1493     Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1494     if (sv && GvNAME(sv)) {
1495         SV * const tmpsv = newSVpvs("");
1496         PerlIO_printf(file, "\t\"%s\"\n",
1497                               generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1498     }
1499     else
1500         (void)PerlIO_putc(file, '\n');
1501 }
1502
1503 void
1504 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1505 {
1506     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1507
1508     Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1509     if (sv && GvNAME(sv)) {
1510        SV *tmp = newSVpvs_flags("", SVs_TEMP);
1511         const char *hvname;
1512         HV * const stash = GvSTASH(sv);
1513         PerlIO_printf(file, "\t");
1514         /* TODO might have an extra \" here */
1515         if (stash && (hvname = HvNAME_get(stash))) {
1516             PerlIO_printf(file, "\"%s\" :: \"",
1517                                   generic_pv_escape(tmp, hvname,
1518                                       HvNAMELEN(stash), HvNAMEUTF8(stash)));
1519         }
1520         PerlIO_printf(file, "%s\"\n",
1521                               generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1522     }
1523     else
1524         (void)PerlIO_putc(file, '\n');
1525 }
1526
1527 const struct flag_to_name first_sv_flags_names[] = {
1528     {SVs_TEMP, "TEMP,"},
1529     {SVs_OBJECT, "OBJECT,"},
1530     {SVs_GMG, "GMG,"},
1531     {SVs_SMG, "SMG,"},
1532     {SVs_RMG, "RMG,"},
1533     {SVf_IOK, "IOK,"},
1534     {SVf_NOK, "NOK,"},
1535     {SVf_POK, "POK,"}
1536 };
1537
1538 const struct flag_to_name second_sv_flags_names[] = {
1539     {SVf_OOK, "OOK,"},
1540     {SVf_FAKE, "FAKE,"},
1541     {SVf_READONLY, "READONLY,"},
1542     {SVf_PROTECT, "PROTECT,"},
1543     {SVf_BREAK, "BREAK,"},
1544     {SVp_IOK, "pIOK,"},
1545     {SVp_NOK, "pNOK,"},
1546     {SVp_POK, "pPOK,"}
1547 };
1548
1549 const struct flag_to_name cv_flags_names[] = {
1550     {CVf_ANON, "ANON,"},
1551     {CVf_UNIQUE, "UNIQUE,"},
1552     {CVf_CLONE, "CLONE,"},
1553     {CVf_CLONED, "CLONED,"},
1554     {CVf_CONST, "CONST,"},
1555     {CVf_NODEBUG, "NODEBUG,"},
1556     {CVf_LVALUE, "LVALUE,"},
1557     {CVf_METHOD, "METHOD,"},
1558     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1559     {CVf_CVGV_RC, "CVGV_RC,"},
1560     {CVf_DYNFILE, "DYNFILE,"},
1561     {CVf_AUTOLOAD, "AUTOLOAD,"},
1562     {CVf_HASEVAL, "HASEVAL,"},
1563     {CVf_SLABBED, "SLABBED,"},
1564     {CVf_NAMED, "NAMED,"},
1565     {CVf_LEXICAL, "LEXICAL,"},
1566     {CVf_ISXSUB, "ISXSUB,"}
1567 };
1568
1569 const struct flag_to_name hv_flags_names[] = {
1570     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1571     {SVphv_LAZYDEL, "LAZYDEL,"},
1572     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1573     {SVf_AMAGIC, "OVERLOAD,"},
1574     {SVphv_CLONEABLE, "CLONEABLE,"}
1575 };
1576
1577 const struct flag_to_name gp_flags_names[] = {
1578     {GVf_INTRO, "INTRO,"},
1579     {GVf_MULTI, "MULTI,"},
1580     {GVf_ASSUMECV, "ASSUMECV,"},
1581 };
1582
1583 const struct flag_to_name gp_flags_imported_names[] = {
1584     {GVf_IMPORTED_SV, " SV"},
1585     {GVf_IMPORTED_AV, " AV"},
1586     {GVf_IMPORTED_HV, " HV"},
1587     {GVf_IMPORTED_CV, " CV"},
1588 };
1589
1590 /* NOTE: this structure is mostly duplicative of one generated by
1591  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1592  * the two. - Yves */
1593 const struct flag_to_name regexp_extflags_names[] = {
1594     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1595     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1596     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1597     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1598     {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1599     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1600     {RXf_PMf_NOCAPTURE,   "PMf_NOCAPURE,"},
1601     {RXf_IS_ANCHORED,     "IS_ANCHORED,"},
1602     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1603     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1604     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1605     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1606     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1607     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1608     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1609     {RXf_SPLIT,           "SPLIT,"},
1610     {RXf_COPY_DONE,       "COPY_DONE,"},
1611     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1612     {RXf_TAINTED,         "TAINTED,"},
1613     {RXf_START_ONLY,      "START_ONLY,"},
1614     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1615     {RXf_WHITE,           "WHITE,"},
1616     {RXf_NULL,            "NULL,"},
1617 };
1618
1619 /* NOTE: this structure is mostly duplicative of one generated by
1620  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1621  * the two. - Yves */
1622 const struct flag_to_name regexp_core_intflags_names[] = {
1623     {PREGf_SKIP,            "SKIP,"},
1624     {PREGf_IMPLICIT,        "IMPLICIT,"},
1625     {PREGf_NAUGHTY,         "NAUGHTY,"},
1626     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1627     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1628     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1629     {PREGf_NOSCAN,          "NOSCAN,"},
1630     {PREGf_GPOS_SEEN,       "GPOS_SEEN,"},
1631     {PREGf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1632     {PREGf_ANCH_MBOL,       "ANCH_MBOL,"},
1633     {PREGf_ANCH_SBOL,       "ANCH_SBOL,"},
1634     {PREGf_ANCH_GPOS,       "ANCH_GPOS,"},
1635 };
1636
1637 /* Perl_do_sv_dump():
1638  *
1639  * level:   amount to indent the output
1640  * sv:      the object to dump
1641  * nest:    the current level of recursion
1642  * maxnest: the maximum allowed level of recursion
1643  * dumpops: if true, also dump the ops associated with a CV
1644  * pvlim:   limit on the length of any strings that are output
1645  * */
1646
1647 void
1648 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1649 {
1650     SV *d;
1651     const char *s;
1652     U32 flags;
1653     U32 type;
1654
1655     PERL_ARGS_ASSERT_DO_SV_DUMP;
1656
1657     if (!sv) {
1658         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1659         return;
1660     }
1661
1662     flags = SvFLAGS(sv);
1663     type = SvTYPE(sv);
1664
1665     /* process general SV flags */
1666
1667     d = Perl_newSVpvf(aTHX_
1668                    "(0x%" UVxf ") at 0x%" UVxf "\n%*s  REFCNT = %" IVdf "\n%*s  FLAGS = (",
1669                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1670                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1671                    (int)(PL_dumpindent*level), "");
1672
1673     if ((flags & SVs_PADSTALE))
1674             sv_catpv(d, "PADSTALE,");
1675     if ((flags & SVs_PADTMP))
1676             sv_catpv(d, "PADTMP,");
1677     append_flags(d, flags, first_sv_flags_names);
1678     if (flags & SVf_ROK)  {     
1679                                 sv_catpv(d, "ROK,");
1680         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1681     }
1682     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1683     append_flags(d, flags, second_sv_flags_names);
1684     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1685                            && type != SVt_PVAV) {
1686         if (SvPCS_IMPORTED(sv))
1687                                 sv_catpv(d, "PCS_IMPORTED,");
1688         else
1689                                 sv_catpv(d, "SCREAM,");
1690     }
1691
1692     /* process type-specific SV flags */
1693
1694     switch (type) {
1695     case SVt_PVCV:
1696     case SVt_PVFM:
1697         append_flags(d, CvFLAGS(sv), cv_flags_names);
1698         break;
1699     case SVt_PVHV:
1700         append_flags(d, flags, hv_flags_names);
1701         break;
1702     case SVt_PVGV:
1703     case SVt_PVLV:
1704         if (isGV_with_GP(sv)) {
1705             append_flags(d, GvFLAGS(sv), gp_flags_names);
1706         }
1707         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1708             sv_catpv(d, "IMPORT");
1709             if (GvIMPORTED(sv) == GVf_IMPORTED)
1710                 sv_catpv(d, "ALL,");
1711             else {
1712                 sv_catpv(d, "(");
1713                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1714                 sv_catpv(d, " ),");
1715             }
1716         }
1717         /* FALLTHROUGH */
1718     case SVt_PVMG:
1719     default:
1720         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1721         break;
1722
1723     case SVt_PVAV:
1724         break;
1725     }
1726     /* SVphv_SHAREKEYS is also 0x20000000 */
1727     if ((type != SVt_PVHV) && SvUTF8(sv))
1728         sv_catpv(d, "UTF8");
1729
1730     if (*(SvEND(d) - 1) == ',') {
1731         SvCUR_set(d, SvCUR(d) - 1);
1732         SvPVX(d)[SvCUR(d)] = '\0';
1733     }
1734     sv_catpv(d, ")");
1735     s = SvPVX_const(d);
1736
1737     /* dump initial SV details */
1738
1739 #ifdef DEBUG_LEAKING_SCALARS
1740     Perl_dump_indent(aTHX_ level, file,
1741         "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1742         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1743         sv->sv_debug_line,
1744         sv->sv_debug_inpad ? "for" : "by",
1745         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1746         PTR2UV(sv->sv_debug_parent),
1747         sv->sv_debug_serial
1748     );
1749 #endif
1750     Perl_dump_indent(aTHX_ level, file, "SV = ");
1751
1752     /* Dump SV type */
1753
1754     if (type < SVt_LAST) {
1755         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1756
1757         if (type ==  SVt_NULL) {
1758             SvREFCNT_dec_NN(d);
1759             return;
1760         }
1761     } else {
1762         PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1763         SvREFCNT_dec_NN(d);
1764         return;
1765     }
1766
1767     /* Dump general SV fields */
1768
1769     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1770          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1771          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1772         || (type == SVt_IV && !SvROK(sv))) {
1773         if (SvIsUV(sv)
1774                                      )
1775             Perl_dump_indent(aTHX_ level, file, "  UV = %" UVuf, (UV)SvUVX(sv));
1776         else
1777             Perl_dump_indent(aTHX_ level, file, "  IV = %" IVdf, (IV)SvIVX(sv));
1778         (void)PerlIO_putc(file, '\n');
1779     }
1780
1781     if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1782                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1783                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1784                || type == SVt_NV) {
1785         STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1786         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1787         RESTORE_LC_NUMERIC_UNDERLYING();
1788     }
1789
1790     if (SvROK(sv)) {
1791         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%" UVxf "\n",
1792                                PTR2UV(SvRV(sv)));
1793         if (nest < maxnest)
1794             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1795     }
1796
1797     if (type < SVt_PV) {
1798         SvREFCNT_dec_NN(d);
1799         return;
1800     }
1801
1802     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1803      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1804         const bool re = isREGEXP(sv);
1805         const char * const ptr =
1806             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1807         if (ptr) {
1808             STRLEN delta;
1809             if (SvOOK(sv)) {
1810                 SvOOK_offset(sv, delta);
1811                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %" UVuf "\n",
1812                                  (UV) delta);
1813             } else {
1814                 delta = 0;
1815             }
1816             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%" UVxf " ",
1817                                    PTR2UV(ptr));
1818             if (SvOOK(sv)) {
1819                 PerlIO_printf(file, "( %s . ) ",
1820                               pv_display(d, ptr - delta, delta, 0,
1821                                          pvlim));
1822             }
1823             if (type == SVt_INVLIST) {
1824                 PerlIO_printf(file, "\n");
1825                 /* 4 blanks indents 2 beyond the PV, etc */
1826                 _invlist_dump(file, level, "    ", sv);
1827             }
1828             else {
1829                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1830                                                      re ? 0 : SvLEN(sv),
1831                                                      pvlim));
1832                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1833                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1834                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1835                                                         UNI_DISPLAY_QQ));
1836                 PerlIO_printf(file, "\n");
1837             }
1838             Perl_dump_indent(aTHX_ level, file, "  CUR = %" IVdf "\n", (IV)SvCUR(sv));
1839             if (!re)
1840                 Perl_dump_indent(aTHX_ level, file, "  LEN = %" IVdf "\n",
1841                                        (IV)SvLEN(sv));
1842 #ifdef PERL_COPY_ON_WRITE
1843             if (SvIsCOW(sv) && SvLEN(sv))
1844                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1845                                        CowREFCNT(sv));
1846 #endif
1847         }
1848         else
1849             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1850     }
1851
1852     if (type >= SVt_PVMG) {
1853         if (SvMAGIC(sv))
1854                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1855         if (SvSTASH(sv))
1856             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1857
1858         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1859             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %" IVdf "\n",
1860                                    (IV)BmUSEFUL(sv));
1861         }
1862     }
1863
1864     /* Dump type-specific SV fields */
1865
1866     switch (type) {
1867     case SVt_PVAV:
1868         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf,
1869                                PTR2UV(AvARRAY(sv)));
1870         if (AvARRAY(sv) != AvALLOC(sv)) {
1871             PerlIO_printf(file, " (offset=%" IVdf ")\n",
1872                                 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1873             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%" UVxf "\n",
1874                                    PTR2UV(AvALLOC(sv)));
1875         }
1876         else
1877             (void)PerlIO_putc(file, '\n');
1878         Perl_dump_indent(aTHX_ level, file, "  FILL = %" IVdf "\n",
1879                                (IV)AvFILLp(sv));
1880         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
1881                                (IV)AvMAX(sv));
1882         SvPVCLEAR(d);
1883         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1884         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1885         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1886                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1887         if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1888             SSize_t count;
1889             SV **svp = AvARRAY(MUTABLE_AV(sv));
1890             for (count = 0;
1891                  count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1892                  count++, svp++)
1893             {
1894                 SV* const elt = *svp;
1895                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1896                                        (IV)count);
1897                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1898             }
1899         }
1900         break;
1901     case SVt_PVHV: {
1902         U32 usedkeys;
1903         if (SvOOK(sv)) {
1904             struct xpvhv_aux *const aux = HvAUX(sv);
1905             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %" UVuf "\n",
1906                              (UV)aux->xhv_aux_flags);
1907         }
1908         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1909         usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
1910         if (HvARRAY(sv) && usedkeys) {
1911             /* Show distribution of HEs in the ARRAY */
1912             int freq[200];
1913 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1914             int i;
1915             int max = 0;
1916             U32 pow2 = 2, keys = usedkeys;
1917             NV theoret, sum = 0;
1918
1919             PerlIO_printf(file, "  (");
1920             Zero(freq, FREQ_MAX + 1, int);
1921             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1922                 HE* h;
1923                 int count = 0;
1924                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1925                     count++;
1926                 if (count > FREQ_MAX)
1927                     count = FREQ_MAX;
1928                 freq[count]++;
1929                 if (max < count)
1930                     max = count;
1931             }
1932             for (i = 0; i <= max; i++) {
1933                 if (freq[i]) {
1934                     PerlIO_printf(file, "%d%s:%d", i,
1935                                   (i == FREQ_MAX) ? "+" : "",
1936                                   freq[i]);
1937                     if (i != max)
1938                         PerlIO_printf(file, ", ");
1939                 }
1940             }
1941             (void)PerlIO_putc(file, ')');
1942             /* The "quality" of a hash is defined as the total number of
1943                comparisons needed to access every element once, relative
1944                to the expected number needed for a random hash.
1945
1946                The total number of comparisons is equal to the sum of
1947                the squares of the number of entries in each bucket.
1948                For a random hash of n keys into k buckets, the expected
1949                value is
1950                                 n + n(n-1)/2k
1951             */
1952
1953             for (i = max; i > 0; i--) { /* Precision: count down. */
1954                 sum += freq[i] * i * i;
1955             }
1956             while ((keys = keys >> 1))
1957                 pow2 = pow2 << 1;
1958             theoret = usedkeys;
1959             theoret += theoret * (theoret-1)/pow2;
1960             (void)PerlIO_putc(file, '\n');
1961             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"
1962                                    NVff "%%", theoret/sum*100);
1963         }
1964         (void)PerlIO_putc(file, '\n');
1965         Perl_dump_indent(aTHX_ level, file, "  KEYS = %" IVdf "\n",
1966                                (IV)usedkeys);
1967         {
1968             STRLEN count = 0;
1969             HE **ents = HvARRAY(sv);
1970
1971             if (ents) {
1972                 HE *const *const last = ents + HvMAX(sv);
1973                 count = last + 1 - ents;
1974                 
1975                 do {
1976                     if (!*ents)
1977                         --count;
1978                 } while (++ents <= last);
1979             }
1980
1981             Perl_dump_indent(aTHX_ level, file, "  FILL = %" UVuf "\n",
1982                              (UV)count);
1983         }
1984         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
1985                                (IV)HvMAX(sv));
1986         if (SvOOK(sv)) {
1987             Perl_dump_indent(aTHX_ level, file, "  RITER = %" IVdf "\n",
1988                                    (IV)HvRITER_get(sv));
1989             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%" UVxf "\n",
1990                                    PTR2UV(HvEITER_get(sv)));
1991 #ifdef PERL_HASH_RANDOMIZE_KEYS
1992             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%" UVxf,
1993                                    (UV)HvRAND_get(sv));
1994             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1995                 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
1996                                     (UV)HvLASTRAND_get(sv));
1997             }
1998 #endif
1999             (void)PerlIO_putc(file, '\n');
2000         }
2001         {
2002             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2003             if (mg && mg->mg_obj) {
2004                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2005             }
2006         }
2007         {
2008             const char * const hvname = HvNAME_get(sv);
2009             if (hvname) {
2010                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2011                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2012                                        generic_pv_escape( tmpsv, hvname,
2013                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
2014         }
2015         }
2016         if (SvOOK(sv)) {
2017             AV * const backrefs
2018                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2019             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2020             if (HvAUX(sv)->xhv_name_count)
2021                 Perl_dump_indent(aTHX_
2022                  level, file, "  NAMECOUNT = %" IVdf "\n",
2023                  (IV)HvAUX(sv)->xhv_name_count
2024                 );
2025             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2026                 const I32 count = HvAUX(sv)->xhv_name_count;
2027                 if (count) {
2028                     SV * const names = newSVpvs_flags("", SVs_TEMP);
2029                     /* The starting point is the first element if count is
2030                        positive and the second element if count is negative. */
2031                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2032                         + (count < 0 ? 1 : 0);
2033                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2034                         + (count < 0 ? -count : count);
2035                     while (hekp < endp) {
2036                         if (*hekp) {
2037                             SV *tmp = newSVpvs_flags("", SVs_TEMP);
2038                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2039                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2040                         } else {
2041                             /* This should never happen. */
2042                             sv_catpvs(names, ", (null)");
2043                         }
2044                         ++hekp;
2045                     }
2046                     Perl_dump_indent(aTHX_
2047                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
2048                     );
2049                 }
2050                 else {
2051                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2052                     const char *const hvename = HvENAME_get(sv);
2053                     Perl_dump_indent(aTHX_
2054                      level, file, "  ENAME = \"%s\"\n",
2055                      generic_pv_escape(tmp, hvename,
2056                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2057                 }
2058             }
2059             if (backrefs) {
2060                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%" UVxf "\n",
2061                                  PTR2UV(backrefs));
2062                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2063                            dumpops, pvlim);
2064             }
2065             if (meta) {
2066                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2067                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"
2068                                  UVxf ")\n",
2069                                  generic_pv_escape( tmpsv, meta->mro_which->name,
2070                                 meta->mro_which->length,
2071                                 (meta->mro_which->kflags & HVhek_UTF8)),
2072                                  PTR2UV(meta->mro_which));
2073                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"
2074                                  UVxf "\n",
2075                                  (UV)meta->cache_gen);
2076                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%" UVxf "\n",
2077                                  (UV)meta->pkg_gen);
2078                 if (meta->mro_linear_all) {
2079                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"
2080                                  UVxf "\n",
2081                                  PTR2UV(meta->mro_linear_all));
2082                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2083                            dumpops, pvlim);
2084                 }
2085                 if (meta->mro_linear_current) {
2086                     Perl_dump_indent(aTHX_ level, file,
2087                                  "  MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2088                                  PTR2UV(meta->mro_linear_current));
2089                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2090                            dumpops, pvlim);
2091                 }
2092                 if (meta->mro_nextmethod) {
2093                     Perl_dump_indent(aTHX_ level, file,
2094                                  "  MRO_NEXTMETHOD = 0x%" UVxf "\n",
2095                                  PTR2UV(meta->mro_nextmethod));
2096                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2097                            dumpops, pvlim);
2098                 }
2099                 if (meta->isa) {
2100                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%" UVxf "\n",
2101                                  PTR2UV(meta->isa));
2102                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2103                            dumpops, pvlim);
2104                 }
2105             }
2106         }
2107         if (nest < maxnest) {
2108             HV * const hv = MUTABLE_HV(sv);
2109             STRLEN i;
2110             HE *he;
2111
2112             if (HvARRAY(hv)) {
2113                 int count = maxnest - nest;
2114                 for (i=0; i <= HvMAX(hv); i++) {
2115                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2116                         U32 hash;
2117                         SV * keysv;
2118                         const char * keypv;
2119                         SV * elt;
2120                         STRLEN len;
2121
2122                         if (count-- <= 0) goto DONEHV;
2123
2124                         hash = HeHASH(he);
2125                         keysv = hv_iterkeysv(he);
2126                         keypv = SvPV_const(keysv, len);
2127                         elt = HeVAL(he);
2128
2129                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2130                         if (SvUTF8(keysv))
2131                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2132                         if (HvEITER_get(hv) == he)
2133                             PerlIO_printf(file, "[CURRENT] ");
2134                         PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
2135                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2136                     }
2137                 }
2138               DONEHV:;
2139             }
2140         }
2141         break;
2142     } /* case SVt_PVHV */
2143
2144     case SVt_PVCV:
2145         if (CvAUTOLOAD(sv)) {
2146             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2147             STRLEN len;
2148             const char *const name =  SvPV_const(sv, len);
2149             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
2150                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2151         }
2152         if (SvPOK(sv)) {
2153             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2154             const char *const proto = CvPROTO(sv);
2155             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
2156                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2157                                 SvUTF8(sv)));
2158         }
2159         /* FALLTHROUGH */
2160     case SVt_PVFM:
2161         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
2162         if (!CvISXSUB(sv)) {
2163             if (CvSTART(sv)) {
2164                 if (CvSLABBED(sv))
2165                     Perl_dump_indent(aTHX_ level, file,
2166                                  "  SLAB = 0x%" UVxf "\n",
2167                                  PTR2UV(CvSTART(sv)));
2168                 else
2169                     Perl_dump_indent(aTHX_ level, file,
2170                                  "  START = 0x%" UVxf " ===> %" IVdf "\n",
2171                                  PTR2UV(CvSTART(sv)),
2172                                  (IV)sequence_num(CvSTART(sv)));
2173             }
2174             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%" UVxf "\n",
2175                              PTR2UV(CvROOT(sv)));
2176             if (CvROOT(sv) && dumpops) {
2177                 do_op_dump(level+1, file, CvROOT(sv));
2178             }
2179         } else {
2180             SV * const constant = cv_const_sv((const CV *)sv);
2181
2182             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2183
2184             if (constant) {
2185                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%" UVxf
2186                                  " (CONST SV)\n",
2187                                  PTR2UV(CvXSUBANY(sv).any_ptr));
2188                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2189                            pvlim);
2190             } else {
2191                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %" IVdf "\n",
2192                                  (IV)CvXSUBANY(sv).any_i32);
2193             }
2194         }
2195         if (CvNAMED(sv))
2196             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2197                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
2198         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
2199         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
2200         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"
2201                                       IVdf "\n", (IV)CvDEPTH(sv));
2202         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n",
2203                                (UV)CvFLAGS(sv));
2204         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2205         if (!CvISXSUB(sv)) {
2206             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2207             if (nest < maxnest) {
2208                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2209             }
2210         }
2211         else
2212             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
2213         {
2214             const CV * const outside = CvOUTSIDE(sv);
2215             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%" UVxf " (%s)\n",
2216                         PTR2UV(outside),
2217                         (!outside ? "null"
2218                          : CvANON(outside) ? "ANON"
2219                          : (outside == PL_main_cv) ? "MAIN"
2220                          : CvUNIQUE(outside) ? "UNIQUE"
2221                          : CvGV(outside) ?
2222                              generic_pv_escape(
2223                                  newSVpvs_flags("", SVs_TEMP),
2224                                  GvNAME(CvGV(outside)),
2225                                  GvNAMELEN(CvGV(outside)),
2226                                  GvNAMEUTF8(CvGV(outside)))
2227                          : "UNDEFINED"));
2228         }
2229         if (CvOUTSIDE(sv)
2230          && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2231             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2232         break;
2233
2234     case SVt_PVGV:
2235     case SVt_PVLV:
2236         if (type == SVt_PVLV) {
2237             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2238             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2239             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2240             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2241             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2242             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2243                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2244                     dumpops, pvlim);
2245         }
2246         if (isREGEXP(sv)) goto dumpregexp;
2247         if (!isGV_with_GP(sv))
2248             break;
2249         {
2250             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2251             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2252                      generic_pv_escape(tmpsv, GvNAME(sv),
2253                                        GvNAMELEN(sv),
2254                                        GvNAMEUTF8(sv)));
2255         }
2256         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2257         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2258         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2259         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2260         if (!GvGP(sv))
2261             break;
2262         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2263         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2264         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2265         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%" UVxf "  \n", PTR2UV(GvFORM(sv)));
2266         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2267         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2268         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2269         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2270         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%" UVxf
2271                                             " (%s)\n",
2272                                (UV)GvGPFLAGS(sv),
2273                                "");
2274         Perl_dump_indent(aTHX_ level, file, "    LINE = %" IVdf "\n", (IV)GvLINE(sv));
2275         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2276         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2277         break;
2278     case SVt_PVIO:
2279         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2280         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2281         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2282         Perl_dump_indent(aTHX_ level, file, "  LINES = %" IVdf "\n", (IV)IoLINES(sv));
2283         Perl_dump_indent(aTHX_ level, file, "  PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2284         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2285         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2286         if (IoTOP_NAME(sv))
2287             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2288         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2289             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2290         else {
2291             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%" UVxf "\n",
2292                              PTR2UV(IoTOP_GV(sv)));
2293             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2294                         maxnest, dumpops, pvlim);
2295         }
2296         /* Source filters hide things that are not GVs in these three, so let's
2297            be careful out there.  */
2298         if (IoFMT_NAME(sv))
2299             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2300         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2301             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2302         else {
2303             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%" UVxf "\n",
2304                              PTR2UV(IoFMT_GV(sv)));
2305             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2306                         maxnest, dumpops, pvlim);
2307         }
2308         if (IoBOTTOM_NAME(sv))
2309             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2310         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2311             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2312         else {
2313             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%" UVxf "\n",
2314                              PTR2UV(IoBOTTOM_GV(sv)));
2315             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2316                         maxnest, dumpops, pvlim);
2317         }
2318         if (isPRINT(IoTYPE(sv)))
2319             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2320         else
2321             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2322         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2323         break;
2324     case SVt_REGEXP:
2325       dumpregexp:
2326         {
2327             struct regexp * const r = ReANY((REGEXP*)sv);
2328
2329 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2330             sv_setpv(d,"");                                 \
2331             append_flags(d, flags, names);     \
2332             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2333                 SvCUR_set(d, SvCUR(d) - 1);                 \
2334                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2335             }                                               \
2336 } STMT_END
2337             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2338             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%" UVxf " (%s)\n",
2339                                 (UV)(r->compflags), SvPVX_const(d));
2340
2341             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2342             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%" UVxf " (%s)\n",
2343                                 (UV)(r->extflags), SvPVX_const(d));
2344
2345             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%" UVxf " (%s)\n",
2346                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2347             if (r->engine == &PL_core_reg_engine) {
2348                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2349                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf " (%s)\n",
2350                                 (UV)(r->intflags), SvPVX_const(d));
2351             } else {
2352                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf "\n",
2353                                 (UV)(r->intflags));
2354             }
2355 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2356             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %" UVuf "\n",
2357                                 (UV)(r->nparens));
2358             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %" UVuf "\n",
2359                                 (UV)(r->lastparen));
2360             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %" UVuf "\n",
2361                                 (UV)(r->lastcloseparen));
2362             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %" IVdf "\n",
2363                                 (IV)(r->minlen));
2364             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %" IVdf "\n",
2365                                 (IV)(r->minlenret));
2366             Perl_dump_indent(aTHX_ level, file, "  GOFS = %" UVuf "\n",
2367                                 (UV)(r->gofs));
2368             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %" UVuf "\n",
2369                                 (UV)(r->pre_prefix));
2370             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %" IVdf "\n",
2371                                 (IV)(r->sublen));
2372             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %" IVdf "\n",
2373                                 (IV)(r->suboffset));
2374             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %" IVdf "\n",
2375                                 (IV)(r->subcoffset));
2376             if (r->subbeg)
2377                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%" UVxf " %s\n",
2378                             PTR2UV(r->subbeg),
2379                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2380             else
2381                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2382             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%" UVxf "\n",
2383                                 PTR2UV(r->mother_re));
2384             if (nest < maxnest && r->mother_re)
2385                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2386                            maxnest, dumpops, pvlim);
2387             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%" UVxf "\n",
2388                                 PTR2UV(r->paren_names));
2389             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%" UVxf "\n",
2390                                 PTR2UV(r->substrs));
2391             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%" UVxf "\n",
2392                                 PTR2UV(r->pprivate));
2393             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%" UVxf "\n",
2394                                 PTR2UV(r->offs));
2395             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%" UVxf "\n",
2396                                 PTR2UV(r->qr_anoncv));
2397 #ifdef PERL_ANY_COW
2398             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%" UVxf "\n",
2399                                 PTR2UV(r->saved_copy));
2400 #endif
2401         }
2402         break;
2403     }
2404     SvREFCNT_dec_NN(d);
2405 }
2406
2407 /*
2408 =for apidoc sv_dump
2409
2410 Dumps the contents of an SV to the C<STDERR> filehandle.
2411
2412 For an example of its output, see L<Devel::Peek>.
2413
2414 =cut
2415 */
2416
2417 void
2418 Perl_sv_dump(pTHX_ SV *sv)
2419 {
2420     if (sv && SvROK(sv))
2421         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2422     else
2423         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2424 }
2425
2426 int
2427 Perl_runops_debug(pTHX)
2428 {
2429 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2430     SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2431
2432     PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2433 #endif
2434
2435     if (!PL_op) {
2436         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2437         return 0;
2438     }
2439     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2440     do {
2441 #ifdef PERL_TRACE_OPS
2442         ++PL_op_exec_cnt[PL_op->op_type];
2443 #endif
2444 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2445         if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2446             Perl_croak_nocontext(
2447                 "panic: previous op failed to extend arg stack: "
2448                 "base=%p, sp=%p, hwm=%p\n",
2449                     PL_stack_base, PL_stack_sp,
2450                     PL_stack_base + PL_curstackinfo->si_stack_hwm);
2451         PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2452 #endif
2453         if (PL_debug) {
2454             ENTER;
2455             SAVETMPS;
2456             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2457                 PerlIO_printf(Perl_debug_log,
2458                               "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2459                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2460                               PTR2UV(*PL_watchaddr));
2461             if (DEBUG_s_TEST_) {
2462                 if (DEBUG_v_TEST_) {
2463                     PerlIO_printf(Perl_debug_log, "\n");
2464                     deb_stack_all();
2465                 }
2466                 else
2467                     debstack();
2468             }
2469
2470
2471             if (DEBUG_t_TEST_) debop(PL_op);
2472             if (DEBUG_P_TEST_) debprof(PL_op);
2473             FREETMPS;
2474             LEAVE;
2475         }
2476
2477         PERL_DTRACE_PROBE_OP(PL_op);
2478     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2479     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2480     PERL_ASYNC_CHECK();
2481
2482 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2483     if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2484         PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2485 #endif
2486     TAINT_NOT;
2487     return 0;
2488 }
2489
2490
2491 /* print the names of the n lexical vars starting at pad offset off */
2492
2493 STATIC void
2494 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2495 {
2496     PADNAME *sv;
2497     CV * const cv = deb_curcv(cxstack_ix);
2498     PADNAMELIST *comppad = NULL;
2499     int i;
2500
2501     if (cv) {
2502         PADLIST * const padlist = CvPADLIST(cv);
2503         comppad = PadlistNAMES(padlist);
2504     }
2505     if (paren)
2506         PerlIO_printf(Perl_debug_log, "(");
2507     for (i = 0; i < n; i++) {
2508         if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2509             PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2510         else
2511             PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2512                     (UV)(off+i));
2513         if (i < n - 1)
2514             PerlIO_printf(Perl_debug_log, ",");
2515     }
2516     if (paren)
2517         PerlIO_printf(Perl_debug_log, ")");
2518 }
2519
2520
2521 /* append to the out SV, the name of the lexical at offset off in the CV
2522  * cv */
2523
2524 static void
2525 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2526         bool paren, bool is_scalar)
2527 {
2528     PADNAME *sv;
2529     PADNAMELIST *namepad = NULL;
2530     int i;
2531
2532     if (cv) {
2533         PADLIST * const padlist = CvPADLIST(cv);
2534         namepad = PadlistNAMES(padlist);
2535     }
2536
2537     if (paren)
2538         sv_catpvs_nomg(out, "(");
2539     for (i = 0; i < n; i++) {
2540         if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2541         {
2542             STRLEN cur = SvCUR(out);
2543             Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2544                                  UTF8fARG(1, PadnameLEN(sv) - 1,
2545                                           PadnamePV(sv) + 1));
2546             if (is_scalar)
2547                 SvPVX(out)[cur] = '$';
2548         }
2549         else
2550             Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2551         if (i < n - 1)
2552             sv_catpvs_nomg(out, ",");
2553     }
2554     if (paren)
2555         sv_catpvs_nomg(out, "(");
2556 }
2557
2558
2559 static void
2560 S_append_gv_name(pTHX_ GV *gv, SV *out)
2561 {
2562     SV *sv;
2563     if (!gv) {
2564         sv_catpvs_nomg(out, "<NULLGV>");
2565         return;
2566     }
2567     sv = newSV(0);
2568     gv_fullname4(sv, gv, NULL, FALSE);
2569     Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2570     SvREFCNT_dec_NN(sv);
2571 }
2572
2573 #ifdef USE_ITHREADS
2574 #  define ITEM_SV(item) (comppad ? \
2575     *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2576 #else
2577 #  define ITEM_SV(item) UNOP_AUX_item_sv(item)
2578 #endif
2579
2580
2581 /* return a temporary SV containing a stringified representation of
2582  * the op_aux field of a MULTIDEREF op, associated with CV cv
2583  */
2584
2585 SV*
2586 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2587 {
2588     UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2589     UV actions = items->uv;
2590     SV *sv;
2591     bool last = 0;
2592     bool is_hash = FALSE;
2593     int derefs = 0;
2594     SV *out = newSVpvn_flags("",0,SVs_TEMP);
2595 #ifdef USE_ITHREADS
2596     PAD *comppad;
2597
2598     if (cv) {
2599         PADLIST *padlist = CvPADLIST(cv);
2600         comppad = PadlistARRAY(padlist)[1];
2601     }
2602     else
2603         comppad = NULL;
2604 #endif
2605
2606     PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2607
2608     while (!last) {
2609         switch (actions & MDEREF_ACTION_MASK) {
2610
2611         case MDEREF_reload:
2612             actions = (++items)->uv;
2613             continue;
2614             NOT_REACHED; /* NOTREACHED */
2615
2616         case MDEREF_HV_padhv_helem:
2617             is_hash = TRUE;
2618             /* FALLTHROUGH */
2619         case MDEREF_AV_padav_aelem:
2620             derefs = 1;
2621             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2622             goto do_elem;
2623             NOT_REACHED; /* NOTREACHED */
2624
2625         case MDEREF_HV_gvhv_helem:
2626             is_hash = TRUE;
2627             /* FALLTHROUGH */
2628         case MDEREF_AV_gvav_aelem:
2629             derefs = 1;
2630             items++;
2631             sv = ITEM_SV(items);
2632             S_append_gv_name(aTHX_ (GV*)sv, out);
2633             goto do_elem;
2634             NOT_REACHED; /* NOTREACHED */
2635
2636         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2637             is_hash = TRUE;
2638             /* FALLTHROUGH */
2639         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2640             items++;
2641             sv = ITEM_SV(items);
2642             S_append_gv_name(aTHX_ (GV*)sv, out);
2643             goto do_vivify_rv2xv_elem;
2644             NOT_REACHED; /* NOTREACHED */
2645
2646         case MDEREF_HV_padsv_vivify_rv2hv_helem:
2647             is_hash = TRUE;
2648             /* FALLTHROUGH */
2649         case MDEREF_AV_padsv_vivify_rv2av_aelem:
2650             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2651             goto do_vivify_rv2xv_elem;
2652             NOT_REACHED; /* NOTREACHED */
2653
2654         case MDEREF_HV_pop_rv2hv_helem:
2655         case MDEREF_HV_vivify_rv2hv_helem:
2656             is_hash = TRUE;
2657             /* FALLTHROUGH */
2658         do_vivify_rv2xv_elem:
2659         case MDEREF_AV_pop_rv2av_aelem:
2660         case MDEREF_AV_vivify_rv2av_aelem:
2661             if (!derefs++)
2662                 sv_catpvs_nomg(out, "->");
2663         do_elem:
2664             if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2665                 sv_catpvs_nomg(out, "->");
2666                 last = 1;
2667                 break;
2668             }
2669
2670             sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2671             switch (actions & MDEREF_INDEX_MASK) {
2672             case MDEREF_INDEX_const:
2673                 if (is_hash) {
2674                     items++;
2675                     sv = ITEM_SV(items);
2676                     if (!sv)
2677                         sv_catpvs_nomg(out, "???");
2678                     else {
2679                         STRLEN cur;
2680                         char *s;
2681                         s = SvPV(sv, cur);
2682                         pv_pretty(out, s, cur, 30,
2683                                     NULL, NULL,
2684                                     (PERL_PV_PRETTY_NOCLEAR
2685                                     |PERL_PV_PRETTY_QUOTE
2686                                     |PERL_PV_PRETTY_ELLIPSES));
2687                     }
2688                 }
2689                 else
2690                     Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2691                 break;
2692             case MDEREF_INDEX_padsv:
2693                 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2694                 break;
2695             case MDEREF_INDEX_gvsv:
2696                 items++;
2697                 sv = ITEM_SV(items);
2698                 S_append_gv_name(aTHX_ (GV*)sv, out);
2699                 break;
2700             }
2701             sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2702
2703             if (actions & MDEREF_FLAG_last)
2704                 last = 1;
2705             is_hash = FALSE;
2706
2707             break;
2708
2709         default:
2710             PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2711                 (int)(actions & MDEREF_ACTION_MASK));
2712             last = 1;
2713             break;
2714
2715         } /* switch */
2716
2717         actions >>= MDEREF_SHIFT;
2718     } /* while */
2719     return out;
2720 }
2721
2722
2723 I32
2724 Perl_debop(pTHX_ const OP *o)
2725 {
2726     PERL_ARGS_ASSERT_DEBOP;
2727
2728     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2729         return 0;
2730
2731     Perl_deb(aTHX_ "%s", OP_NAME(o));
2732     switch (o->op_type) {
2733     case OP_CONST:
2734     case OP_HINTSEVAL:
2735         /* With ITHREADS, consts are stored in the pad, and the right pad
2736          * may not be active here, so check.
2737          * Looks like only during compiling the pads are illegal.
2738          */
2739 #ifdef USE_ITHREADS
2740         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2741 #endif
2742             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2743         break;
2744     case OP_GVSV:
2745     case OP_GV:
2746         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2747                 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
2748         break;
2749
2750     case OP_PADSV:
2751     case OP_PADAV:
2752     case OP_PADHV:
2753     case OP_ARGELEM:
2754         S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2755         break;
2756
2757     case OP_PADRANGE:
2758         S_deb_padvar(aTHX_ o->op_targ,
2759                         o->op_private & OPpPADRANGE_COUNTMASK, 1);
2760         break;
2761
2762     case OP_MULTIDEREF:
2763         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2764             SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2765         break;
2766
2767     default:
2768         break;
2769     }
2770     PerlIO_printf(Perl_debug_log, "\n");
2771     return 0;
2772 }
2773
2774
2775 /*
2776 =for apidoc op_class
2777
2778 Given an op, determine what type of struct it has been allocated as.
2779 Returns one of the OPclass enums, such as OPclass_LISTOP.
2780
2781 =cut
2782 */
2783
2784
2785 OPclass
2786 Perl_op_class(pTHX_ const OP *o)
2787 {
2788     bool custom = 0;
2789
2790     if (!o)
2791         return OPclass_NULL;
2792
2793     if (o->op_type == 0) {
2794         if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2795             return OPclass_COP;
2796         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2797     }
2798
2799     if (o->op_type == OP_SASSIGN)
2800         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2801
2802     if (o->op_type == OP_AELEMFAST) {
2803 #ifdef USE_ITHREADS
2804             return OPclass_PADOP;
2805 #else
2806             return OPclass_SVOP;
2807 #endif
2808     }
2809     
2810 #ifdef USE_ITHREADS
2811     if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2812         o->op_type == OP_RCATLINE)
2813         return OPclass_PADOP;
2814 #endif
2815
2816     if (o->op_type == OP_CUSTOM)
2817         custom = 1;
2818
2819     switch (OP_CLASS(o)) {
2820     case OA_BASEOP:
2821         return OPclass_BASEOP;
2822
2823     case OA_UNOP:
2824         return OPclass_UNOP;
2825
2826     case OA_BINOP:
2827         return OPclass_BINOP;
2828
2829     case OA_LOGOP:
2830         return OPclass_LOGOP;
2831
2832     case OA_LISTOP:
2833         return OPclass_LISTOP;
2834
2835     case OA_PMOP:
2836         return OPclass_PMOP;
2837
2838     case OA_SVOP:
2839         return OPclass_SVOP;
2840
2841     case OA_PADOP:
2842         return OPclass_PADOP;
2843
2844     case OA_PVOP_OR_SVOP:
2845         /*
2846          * Character translations (tr///) are usually a PVOP, keeping a 
2847          * pointer to a table of shorts used to look up translations.
2848          * Under utf8, however, a simple table isn't practical; instead,
2849          * the OP is an SVOP (or, under threads, a PADOP),
2850          * and the SV is a reference to a swash
2851          * (i.e., an RV pointing to an HV).
2852          */
2853         return (!custom &&
2854                    (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2855                )
2856 #if  defined(USE_ITHREADS)
2857                 ? OPclass_PADOP : OPclass_PVOP;
2858 #else
2859                 ? OPclass_SVOP : OPclass_PVOP;
2860 #endif
2861
2862     case OA_LOOP:
2863         return OPclass_LOOP;
2864
2865     case OA_COP:
2866         return OPclass_COP;
2867
2868     case OA_BASEOP_OR_UNOP:
2869         /*
2870          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2871          * whether parens were seen. perly.y uses OPf_SPECIAL to
2872          * signal whether a BASEOP had empty parens or none.
2873          * Some other UNOPs are created later, though, so the best
2874          * test is OPf_KIDS, which is set in newUNOP.
2875          */
2876         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2877
2878     case OA_FILESTATOP:
2879         /*
2880          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2881          * the OPf_REF flag to distinguish between OP types instead of the
2882          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2883          * return OPclass_UNOP so that walkoptree can find our children. If
2884          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2885          * (no argument to the operator) it's an OP; with OPf_REF set it's
2886          * an SVOP (and op_sv is the GV for the filehandle argument).
2887          */
2888         return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2889 #ifdef USE_ITHREADS
2890                 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2891 #else
2892                 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
2893 #endif
2894     case OA_LOOPEXOP:
2895         /*
2896          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
2897          * label was omitted (in which case it's a BASEOP) or else a term was
2898          * seen. In this last case, all except goto are definitely PVOP but
2899          * goto is either a PVOP (with an ordinary constant label), an UNOP
2900          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
2901          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
2902          * get set.
2903          */
2904         if (o->op_flags & OPf_STACKED)
2905             return OPclass_UNOP;
2906         else if (o->op_flags & OPf_SPECIAL)
2907             return OPclass_BASEOP;
2908         else
2909             return OPclass_PVOP;
2910     case OA_METHOP:
2911         return OPclass_METHOP;
2912     case OA_UNOP_AUX:
2913         return OPclass_UNOP_AUX;
2914     }
2915     Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
2916          OP_NAME(o));
2917     return OPclass_BASEOP;
2918 }
2919
2920
2921
2922 STATIC CV*
2923 S_deb_curcv(pTHX_ I32 ix)
2924 {
2925     PERL_SI *si = PL_curstackinfo;
2926     for (; ix >=0; ix--) {
2927         const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2928
2929         if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2930             return cx->blk_sub.cv;
2931         else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2932             return cx->blk_eval.cv;
2933         else if (ix == 0 && si->si_type == PERLSI_MAIN)
2934             return PL_main_cv;
2935         else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2936                && si->si_type == PERLSI_SORT)
2937         {
2938             /* fake sort sub; use CV of caller */
2939             si = si->si_prev;
2940             ix = si->si_cxix + 1;
2941         }
2942     }
2943     return NULL;
2944 }
2945
2946 void
2947 Perl_watch(pTHX_ char **addr)
2948 {
2949     PERL_ARGS_ASSERT_WATCH;
2950
2951     PL_watchaddr = addr;
2952     PL_watchok = *addr;
2953     PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
2954         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2955 }
2956
2957 STATIC void
2958 S_debprof(pTHX_ const OP *o)
2959 {
2960     PERL_ARGS_ASSERT_DEBPROF;
2961
2962     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2963         return;
2964     if (!PL_profiledata)
2965         Newxz(PL_profiledata, MAXO, U32);
2966     ++PL_profiledata[o->op_type];
2967 }
2968
2969 void
2970 Perl_debprofdump(pTHX)
2971 {
2972     unsigned i;
2973     if (!PL_profiledata)
2974         return;
2975     for (i = 0; i < MAXO; i++) {
2976         if (PL_profiledata[i])
2977             PerlIO_printf(Perl_debug_log,
2978                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2979                                        PL_op_name[i]);
2980     }
2981 }
2982
2983
2984 /*
2985  * ex: set ts=8 sts=4 sw=4 et:
2986  */