Use temp files with extensions in rt131211.t on VMS.
[perl.git] / dump.c
1 /*    dump.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *  'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13  *   it has not been hard for me to read your mind and memory.'
14  *
15  *     [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
16  */
17
18 /* This file contains utility routines to dump the contents of SV and OP
19  * structures, as used by command-line options like -Dt and -Dx, and
20  * by Devel::Peek.
21  *
22  * It also holds the debugging version of the  runops function.
23
24 =head1 Display and Dump functions
25  */
26
27 #include "EXTERN.h"
28 #define PERL_IN_DUMP_C
29 #include "perl.h"
30 #include "regcomp.h"
31
32 static const char* const svtypenames[SVt_LAST] = {
33     "NULL",
34     "IV",
35     "NV",
36     "PV",
37     "INVLIST",
38     "PVIV",
39     "PVNV",
40     "PVMG",
41     "REGEXP",
42     "PVGV",
43     "PVLV",
44     "PVAV",
45     "PVHV",
46     "PVCV",
47     "PVFM",
48     "PVIO"
49 };
50
51
52 static const char* const svshorttypenames[SVt_LAST] = {
53     "UNDEF",
54     "IV",
55     "NV",
56     "PV",
57     "INVLST",
58     "PVIV",
59     "PVNV",
60     "PVMG",
61     "REGEXP",
62     "GV",
63     "PVLV",
64     "AV",
65     "HV",
66     "CV",
67     "FM",
68     "IO"
69 };
70
71 struct flag_to_name {
72     U32 flag;
73     const char *name;
74 };
75
76 static void
77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78                const struct flag_to_name *const end)
79 {
80     do {
81         if (flags & start->flag)
82             sv_catpv(sv, start->name);
83     } while (++start < end);
84 }
85
86 #define append_flags(sv, f, flags) \
87     S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
88
89 #define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
90                               (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
91                               PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
92                               | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
93
94 /*
95 =for apidoc pv_escape
96
97 Escapes at most the first 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 && type == SVt_PVLV)
1840                 /* LV-as-REGEXP usurps len field to store poiunter to
1841                  * regexp struct */
1842                 Perl_dump_indent(aTHX_ level, file, "  REGEXP = 0x%" UVxf "\n",
1843                    PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
1844             else
1845                 Perl_dump_indent(aTHX_ level, file, "  LEN = %" IVdf "\n",
1846                                        (IV)SvLEN(sv));
1847 #ifdef PERL_COPY_ON_WRITE
1848             if (SvIsCOW(sv) && SvLEN(sv))
1849                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1850                                        CowREFCNT(sv));
1851 #endif
1852         }
1853         else
1854             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1855     }
1856
1857     if (type >= SVt_PVMG) {
1858         if (SvMAGIC(sv))
1859                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1860         if (SvSTASH(sv))
1861             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1862
1863         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1864             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %" IVdf "\n",
1865                                    (IV)BmUSEFUL(sv));
1866         }
1867     }
1868
1869     /* Dump type-specific SV fields */
1870
1871     switch (type) {
1872     case SVt_PVAV:
1873         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf,
1874                                PTR2UV(AvARRAY(sv)));
1875         if (AvARRAY(sv) != AvALLOC(sv)) {
1876             PerlIO_printf(file, " (offset=%" IVdf ")\n",
1877                                 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1878             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%" UVxf "\n",
1879                                    PTR2UV(AvALLOC(sv)));
1880         }
1881         else
1882             (void)PerlIO_putc(file, '\n');
1883         Perl_dump_indent(aTHX_ level, file, "  FILL = %" IVdf "\n",
1884                                (IV)AvFILLp(sv));
1885         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
1886                                (IV)AvMAX(sv));
1887         SvPVCLEAR(d);
1888         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1889         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1890         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1891                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1892         if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1893             SSize_t count;
1894             SV **svp = AvARRAY(MUTABLE_AV(sv));
1895             for (count = 0;
1896                  count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1897                  count++, svp++)
1898             {
1899                 SV* const elt = *svp;
1900                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1901                                        (IV)count);
1902                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1903             }
1904         }
1905         break;
1906     case SVt_PVHV: {
1907         U32 usedkeys;
1908         if (SvOOK(sv)) {
1909             struct xpvhv_aux *const aux = HvAUX(sv);
1910             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %" UVuf "\n",
1911                              (UV)aux->xhv_aux_flags);
1912         }
1913         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1914         usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
1915         if (HvARRAY(sv) && usedkeys) {
1916             /* Show distribution of HEs in the ARRAY */
1917             int freq[200];
1918 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1919             int i;
1920             int max = 0;
1921             U32 pow2 = 2, keys = usedkeys;
1922             NV theoret, sum = 0;
1923
1924             PerlIO_printf(file, "  (");
1925             Zero(freq, FREQ_MAX + 1, int);
1926             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1927                 HE* h;
1928                 int count = 0;
1929                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1930                     count++;
1931                 if (count > FREQ_MAX)
1932                     count = FREQ_MAX;
1933                 freq[count]++;
1934                 if (max < count)
1935                     max = count;
1936             }
1937             for (i = 0; i <= max; i++) {
1938                 if (freq[i]) {
1939                     PerlIO_printf(file, "%d%s:%d", i,
1940                                   (i == FREQ_MAX) ? "+" : "",
1941                                   freq[i]);
1942                     if (i != max)
1943                         PerlIO_printf(file, ", ");
1944                 }
1945             }
1946             (void)PerlIO_putc(file, ')');
1947             /* The "quality" of a hash is defined as the total number of
1948                comparisons needed to access every element once, relative
1949                to the expected number needed for a random hash.
1950
1951                The total number of comparisons is equal to the sum of
1952                the squares of the number of entries in each bucket.
1953                For a random hash of n keys into k buckets, the expected
1954                value is
1955                                 n + n(n-1)/2k
1956             */
1957
1958             for (i = max; i > 0; i--) { /* Precision: count down. */
1959                 sum += freq[i] * i * i;
1960             }
1961             while ((keys = keys >> 1))
1962                 pow2 = pow2 << 1;
1963             theoret = usedkeys;
1964             theoret += theoret * (theoret-1)/pow2;
1965             (void)PerlIO_putc(file, '\n');
1966             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"
1967                                    NVff "%%", theoret/sum*100);
1968         }
1969         (void)PerlIO_putc(file, '\n');
1970         Perl_dump_indent(aTHX_ level, file, "  KEYS = %" IVdf "\n",
1971                                (IV)usedkeys);
1972         {
1973             STRLEN count = 0;
1974             HE **ents = HvARRAY(sv);
1975
1976             if (ents) {
1977                 HE *const *const last = ents + HvMAX(sv);
1978                 count = last + 1 - ents;
1979                 
1980                 do {
1981                     if (!*ents)
1982                         --count;
1983                 } while (++ents <= last);
1984             }
1985
1986             Perl_dump_indent(aTHX_ level, file, "  FILL = %" UVuf "\n",
1987                              (UV)count);
1988         }
1989         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
1990                                (IV)HvMAX(sv));
1991         if (SvOOK(sv)) {
1992             Perl_dump_indent(aTHX_ level, file, "  RITER = %" IVdf "\n",
1993                                    (IV)HvRITER_get(sv));
1994             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%" UVxf "\n",
1995                                    PTR2UV(HvEITER_get(sv)));
1996 #ifdef PERL_HASH_RANDOMIZE_KEYS
1997             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%" UVxf,
1998                                    (UV)HvRAND_get(sv));
1999             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2000                 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2001                                     (UV)HvLASTRAND_get(sv));
2002             }
2003 #endif
2004             (void)PerlIO_putc(file, '\n');
2005         }
2006         {
2007             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2008             if (mg && mg->mg_obj) {
2009                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2010             }
2011         }
2012         {
2013             const char * const hvname = HvNAME_get(sv);
2014             if (hvname) {
2015                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2016                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2017                                        generic_pv_escape( tmpsv, hvname,
2018                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
2019         }
2020         }
2021         if (SvOOK(sv)) {
2022             AV * const backrefs
2023                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2024             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2025             if (HvAUX(sv)->xhv_name_count)
2026                 Perl_dump_indent(aTHX_
2027                  level, file, "  NAMECOUNT = %" IVdf "\n",
2028                  (IV)HvAUX(sv)->xhv_name_count
2029                 );
2030             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2031                 const I32 count = HvAUX(sv)->xhv_name_count;
2032                 if (count) {
2033                     SV * const names = newSVpvs_flags("", SVs_TEMP);
2034                     /* The starting point is the first element if count is
2035                        positive and the second element if count is negative. */
2036                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2037                         + (count < 0 ? 1 : 0);
2038                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2039                         + (count < 0 ? -count : count);
2040                     while (hekp < endp) {
2041                         if (*hekp) {
2042                             SV *tmp = newSVpvs_flags("", SVs_TEMP);
2043                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2044                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2045                         } else {
2046                             /* This should never happen. */
2047                             sv_catpvs(names, ", (null)");
2048                         }
2049                         ++hekp;
2050                     }
2051                     Perl_dump_indent(aTHX_
2052                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
2053                     );
2054                 }
2055                 else {
2056                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2057                     const char *const hvename = HvENAME_get(sv);
2058                     Perl_dump_indent(aTHX_
2059                      level, file, "  ENAME = \"%s\"\n",
2060                      generic_pv_escape(tmp, hvename,
2061                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2062                 }
2063             }
2064             if (backrefs) {
2065                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%" UVxf "\n",
2066                                  PTR2UV(backrefs));
2067                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2068                            dumpops, pvlim);
2069             }
2070             if (meta) {
2071                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2072                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"
2073                                  UVxf ")\n",
2074                                  generic_pv_escape( tmpsv, meta->mro_which->name,
2075                                 meta->mro_which->length,
2076                                 (meta->mro_which->kflags & HVhek_UTF8)),
2077                                  PTR2UV(meta->mro_which));
2078                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"
2079                                  UVxf "\n",
2080                                  (UV)meta->cache_gen);
2081                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%" UVxf "\n",
2082                                  (UV)meta->pkg_gen);
2083                 if (meta->mro_linear_all) {
2084                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"
2085                                  UVxf "\n",
2086                                  PTR2UV(meta->mro_linear_all));
2087                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2088                            dumpops, pvlim);
2089                 }
2090                 if (meta->mro_linear_current) {
2091                     Perl_dump_indent(aTHX_ level, file,
2092                                  "  MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2093                                  PTR2UV(meta->mro_linear_current));
2094                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2095                            dumpops, pvlim);
2096                 }
2097                 if (meta->mro_nextmethod) {
2098                     Perl_dump_indent(aTHX_ level, file,
2099                                  "  MRO_NEXTMETHOD = 0x%" UVxf "\n",
2100                                  PTR2UV(meta->mro_nextmethod));
2101                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2102                            dumpops, pvlim);
2103                 }
2104                 if (meta->isa) {
2105                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%" UVxf "\n",
2106                                  PTR2UV(meta->isa));
2107                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2108                            dumpops, pvlim);
2109                 }
2110             }
2111         }
2112         if (nest < maxnest) {
2113             HV * const hv = MUTABLE_HV(sv);
2114             STRLEN i;
2115             HE *he;
2116
2117             if (HvARRAY(hv)) {
2118                 int count = maxnest - nest;
2119                 for (i=0; i <= HvMAX(hv); i++) {
2120                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2121                         U32 hash;
2122                         SV * keysv;
2123                         const char * keypv;
2124                         SV * elt;
2125                         STRLEN len;
2126
2127                         if (count-- <= 0) goto DONEHV;
2128
2129                         hash = HeHASH(he);
2130                         keysv = hv_iterkeysv(he);
2131                         keypv = SvPV_const(keysv, len);
2132                         elt = HeVAL(he);
2133
2134                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2135                         if (SvUTF8(keysv))
2136                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2137                         if (HvEITER_get(hv) == he)
2138                             PerlIO_printf(file, "[CURRENT] ");
2139                         PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
2140                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2141                     }
2142                 }
2143               DONEHV:;
2144             }
2145         }
2146         break;
2147     } /* case SVt_PVHV */
2148
2149     case SVt_PVCV:
2150         if (CvAUTOLOAD(sv)) {
2151             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2152             STRLEN len;
2153             const char *const name =  SvPV_const(sv, len);
2154             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
2155                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2156         }
2157         if (SvPOK(sv)) {
2158             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2159             const char *const proto = CvPROTO(sv);
2160             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
2161                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2162                                 SvUTF8(sv)));
2163         }
2164         /* FALLTHROUGH */
2165     case SVt_PVFM:
2166         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
2167         if (!CvISXSUB(sv)) {
2168             if (CvSTART(sv)) {
2169                 if (CvSLABBED(sv))
2170                     Perl_dump_indent(aTHX_ level, file,
2171                                  "  SLAB = 0x%" UVxf "\n",
2172                                  PTR2UV(CvSTART(sv)));
2173                 else
2174                     Perl_dump_indent(aTHX_ level, file,
2175                                  "  START = 0x%" UVxf " ===> %" IVdf "\n",
2176                                  PTR2UV(CvSTART(sv)),
2177                                  (IV)sequence_num(CvSTART(sv)));
2178             }
2179             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%" UVxf "\n",
2180                              PTR2UV(CvROOT(sv)));
2181             if (CvROOT(sv) && dumpops) {
2182                 do_op_dump(level+1, file, CvROOT(sv));
2183             }
2184         } else {
2185             SV * const constant = cv_const_sv((const CV *)sv);
2186
2187             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2188
2189             if (constant) {
2190                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%" UVxf
2191                                  " (CONST SV)\n",
2192                                  PTR2UV(CvXSUBANY(sv).any_ptr));
2193                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2194                            pvlim);
2195             } else {
2196                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %" IVdf "\n",
2197                                  (IV)CvXSUBANY(sv).any_i32);
2198             }
2199         }
2200         if (CvNAMED(sv))
2201             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2202                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
2203         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
2204         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
2205         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"
2206                                       IVdf "\n", (IV)CvDEPTH(sv));
2207         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n",
2208                                (UV)CvFLAGS(sv));
2209         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2210         if (!CvISXSUB(sv)) {
2211             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2212             if (nest < maxnest) {
2213                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2214             }
2215         }
2216         else
2217             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
2218         {
2219             const CV * const outside = CvOUTSIDE(sv);
2220             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%" UVxf " (%s)\n",
2221                         PTR2UV(outside),
2222                         (!outside ? "null"
2223                          : CvANON(outside) ? "ANON"
2224                          : (outside == PL_main_cv) ? "MAIN"
2225                          : CvUNIQUE(outside) ? "UNIQUE"
2226                          : CvGV(outside) ?
2227                              generic_pv_escape(
2228                                  newSVpvs_flags("", SVs_TEMP),
2229                                  GvNAME(CvGV(outside)),
2230                                  GvNAMELEN(CvGV(outside)),
2231                                  GvNAMEUTF8(CvGV(outside)))
2232                          : "UNDEFINED"));
2233         }
2234         if (CvOUTSIDE(sv)
2235          && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2236             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2237         break;
2238
2239     case SVt_PVGV:
2240     case SVt_PVLV:
2241         if (type == SVt_PVLV) {
2242             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2243             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2244             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2245             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2246             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2247             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2248                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2249                     dumpops, pvlim);
2250         }
2251         if (isREGEXP(sv)) goto dumpregexp;
2252         if (!isGV_with_GP(sv))
2253             break;
2254         {
2255             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2256             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2257                      generic_pv_escape(tmpsv, GvNAME(sv),
2258                                        GvNAMELEN(sv),
2259                                        GvNAMEUTF8(sv)));
2260         }
2261         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2262         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2263         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2264         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2265         if (!GvGP(sv))
2266             break;
2267         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2268         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2269         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2270         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%" UVxf "  \n", PTR2UV(GvFORM(sv)));
2271         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2272         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2273         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2274         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2275         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%" UVxf
2276                                             " (%s)\n",
2277                                (UV)GvGPFLAGS(sv),
2278                                "");
2279         Perl_dump_indent(aTHX_ level, file, "    LINE = %" IVdf "\n", (IV)GvLINE(sv));
2280         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2281         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2282         break;
2283     case SVt_PVIO:
2284         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2285         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2286         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2287         Perl_dump_indent(aTHX_ level, file, "  LINES = %" IVdf "\n", (IV)IoLINES(sv));
2288         Perl_dump_indent(aTHX_ level, file, "  PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2289         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2290         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2291         if (IoTOP_NAME(sv))
2292             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2293         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2294             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2295         else {
2296             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%" UVxf "\n",
2297                              PTR2UV(IoTOP_GV(sv)));
2298             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2299                         maxnest, dumpops, pvlim);
2300         }
2301         /* Source filters hide things that are not GVs in these three, so let's
2302            be careful out there.  */
2303         if (IoFMT_NAME(sv))
2304             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2305         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2306             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2307         else {
2308             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%" UVxf "\n",
2309                              PTR2UV(IoFMT_GV(sv)));
2310             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2311                         maxnest, dumpops, pvlim);
2312         }
2313         if (IoBOTTOM_NAME(sv))
2314             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2315         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2316             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2317         else {
2318             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%" UVxf "\n",
2319                              PTR2UV(IoBOTTOM_GV(sv)));
2320             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2321                         maxnest, dumpops, pvlim);
2322         }
2323         if (isPRINT(IoTYPE(sv)))
2324             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2325         else
2326             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2327         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2328         break;
2329     case SVt_REGEXP:
2330       dumpregexp:
2331         {
2332             struct regexp * const r = ReANY((REGEXP*)sv);
2333
2334 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2335             sv_setpv(d,"");                                 \
2336             append_flags(d, flags, names);     \
2337             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2338                 SvCUR_set(d, SvCUR(d) - 1);                 \
2339                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2340             }                                               \
2341 } STMT_END
2342             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2343             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%" UVxf " (%s)\n",
2344                                 (UV)(r->compflags), SvPVX_const(d));
2345
2346             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2347             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%" UVxf " (%s)\n",
2348                                 (UV)(r->extflags), SvPVX_const(d));
2349
2350             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%" UVxf " (%s)\n",
2351                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2352             if (r->engine == &PL_core_reg_engine) {
2353                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2354                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf " (%s)\n",
2355                                 (UV)(r->intflags), SvPVX_const(d));
2356             } else {
2357                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf "\n",
2358                                 (UV)(r->intflags));
2359             }
2360 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2361             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %" UVuf "\n",
2362                                 (UV)(r->nparens));
2363             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %" UVuf "\n",
2364                                 (UV)(r->lastparen));
2365             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %" UVuf "\n",
2366                                 (UV)(r->lastcloseparen));
2367             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %" IVdf "\n",
2368                                 (IV)(r->minlen));
2369             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %" IVdf "\n",
2370                                 (IV)(r->minlenret));
2371             Perl_dump_indent(aTHX_ level, file, "  GOFS = %" UVuf "\n",
2372                                 (UV)(r->gofs));
2373             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %" UVuf "\n",
2374                                 (UV)(r->pre_prefix));
2375             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %" IVdf "\n",
2376                                 (IV)(r->sublen));
2377             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %" IVdf "\n",
2378                                 (IV)(r->suboffset));
2379             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %" IVdf "\n",
2380                                 (IV)(r->subcoffset));
2381             if (r->subbeg)
2382                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%" UVxf " %s\n",
2383                             PTR2UV(r->subbeg),
2384                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2385             else
2386                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2387             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%" UVxf "\n",
2388                                 PTR2UV(r->mother_re));
2389             if (nest < maxnest && r->mother_re)
2390                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2391                            maxnest, dumpops, pvlim);
2392             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%" UVxf "\n",
2393                                 PTR2UV(r->paren_names));
2394             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%" UVxf "\n",
2395                                 PTR2UV(r->substrs));
2396             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%" UVxf "\n",
2397                                 PTR2UV(r->pprivate));
2398             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%" UVxf "\n",
2399                                 PTR2UV(r->offs));
2400             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%" UVxf "\n",
2401                                 PTR2UV(r->qr_anoncv));
2402 #ifdef PERL_ANY_COW
2403             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%" UVxf "\n",
2404                                 PTR2UV(r->saved_copy));
2405 #endif
2406         }
2407         break;
2408     }
2409     SvREFCNT_dec_NN(d);
2410 }
2411
2412 /*
2413 =for apidoc sv_dump
2414
2415 Dumps the contents of an SV to the C<STDERR> filehandle.
2416
2417 For an example of its output, see L<Devel::Peek>.
2418
2419 =cut
2420 */
2421
2422 void
2423 Perl_sv_dump(pTHX_ SV *sv)
2424 {
2425     if (sv && SvROK(sv))
2426         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2427     else
2428         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2429 }
2430
2431 int
2432 Perl_runops_debug(pTHX)
2433 {
2434 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2435     SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2436
2437     PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2438 #endif
2439
2440     if (!PL_op) {
2441         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2442         return 0;
2443     }
2444     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2445     do {
2446 #ifdef PERL_TRACE_OPS
2447         ++PL_op_exec_cnt[PL_op->op_type];
2448 #endif
2449 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2450         if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2451             Perl_croak_nocontext(
2452                 "panic: previous op failed to extend arg stack: "
2453                 "base=%p, sp=%p, hwm=%p\n",
2454                     PL_stack_base, PL_stack_sp,
2455                     PL_stack_base + PL_curstackinfo->si_stack_hwm);
2456         PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2457 #endif
2458         if (PL_debug) {
2459             ENTER;
2460             SAVETMPS;
2461             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2462                 PerlIO_printf(Perl_debug_log,
2463                               "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2464                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2465                               PTR2UV(*PL_watchaddr));
2466             if (DEBUG_s_TEST_) {
2467                 if (DEBUG_v_TEST_) {
2468                     PerlIO_printf(Perl_debug_log, "\n");
2469                     deb_stack_all();
2470                 }
2471                 else
2472                     debstack();
2473             }
2474
2475
2476             if (DEBUG_t_TEST_) debop(PL_op);
2477             if (DEBUG_P_TEST_) debprof(PL_op);
2478             FREETMPS;
2479             LEAVE;
2480         }
2481
2482         PERL_DTRACE_PROBE_OP(PL_op);
2483     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2484     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2485     PERL_ASYNC_CHECK();
2486
2487 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2488     if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2489         PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2490 #endif
2491     TAINT_NOT;
2492     return 0;
2493 }
2494
2495
2496 /* print the names of the n lexical vars starting at pad offset off */
2497
2498 STATIC void
2499 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2500 {
2501     PADNAME *sv;
2502     CV * const cv = deb_curcv(cxstack_ix);
2503     PADNAMELIST *comppad = NULL;
2504     int i;
2505
2506     if (cv) {
2507         PADLIST * const padlist = CvPADLIST(cv);
2508         comppad = PadlistNAMES(padlist);
2509     }
2510     if (paren)
2511         PerlIO_printf(Perl_debug_log, "(");
2512     for (i = 0; i < n; i++) {
2513         if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2514             PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2515         else
2516             PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2517                     (UV)(off+i));
2518         if (i < n - 1)
2519             PerlIO_printf(Perl_debug_log, ",");
2520     }
2521     if (paren)
2522         PerlIO_printf(Perl_debug_log, ")");
2523 }
2524
2525
2526 /* append to the out SV, the name of the lexical at offset off in the CV
2527  * cv */
2528
2529 static void
2530 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2531         bool paren, bool is_scalar)
2532 {
2533     PADNAME *sv;
2534     PADNAMELIST *namepad = NULL;
2535     int i;
2536
2537     if (cv) {
2538         PADLIST * const padlist = CvPADLIST(cv);
2539         namepad = PadlistNAMES(padlist);
2540     }
2541
2542     if (paren)
2543         sv_catpvs_nomg(out, "(");
2544     for (i = 0; i < n; i++) {
2545         if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2546         {
2547             STRLEN cur = SvCUR(out);
2548             Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2549                                  UTF8fARG(1, PadnameLEN(sv) - 1,
2550                                           PadnamePV(sv) + 1));
2551             if (is_scalar)
2552                 SvPVX(out)[cur] = '$';
2553         }
2554         else
2555             Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2556         if (i < n - 1)
2557             sv_catpvs_nomg(out, ",");
2558     }
2559     if (paren)
2560         sv_catpvs_nomg(out, "(");
2561 }
2562
2563
2564 static void
2565 S_append_gv_name(pTHX_ GV *gv, SV *out)
2566 {
2567     SV *sv;
2568     if (!gv) {
2569         sv_catpvs_nomg(out, "<NULLGV>");
2570         return;
2571     }
2572     sv = newSV(0);
2573     gv_fullname4(sv, gv, NULL, FALSE);
2574     Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2575     SvREFCNT_dec_NN(sv);
2576 }
2577
2578 #ifdef USE_ITHREADS
2579 #  define ITEM_SV(item) (comppad ? \
2580     *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2581 #else
2582 #  define ITEM_SV(item) UNOP_AUX_item_sv(item)
2583 #endif
2584
2585
2586 /* return a temporary SV containing a stringified representation of
2587  * the op_aux field of a MULTIDEREF op, associated with CV cv
2588  */
2589
2590 SV*
2591 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2592 {
2593     UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2594     UV actions = items->uv;
2595     SV *sv;
2596     bool last = 0;
2597     bool is_hash = FALSE;
2598     int derefs = 0;
2599     SV *out = newSVpvn_flags("",0,SVs_TEMP);
2600 #ifdef USE_ITHREADS
2601     PAD *comppad;
2602
2603     if (cv) {
2604         PADLIST *padlist = CvPADLIST(cv);
2605         comppad = PadlistARRAY(padlist)[1];
2606     }
2607     else
2608         comppad = NULL;
2609 #endif
2610
2611     PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2612
2613     while (!last) {
2614         switch (actions & MDEREF_ACTION_MASK) {
2615
2616         case MDEREF_reload:
2617             actions = (++items)->uv;
2618             continue;
2619             NOT_REACHED; /* NOTREACHED */
2620
2621         case MDEREF_HV_padhv_helem:
2622             is_hash = TRUE;
2623             /* FALLTHROUGH */
2624         case MDEREF_AV_padav_aelem:
2625             derefs = 1;
2626             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2627             goto do_elem;
2628             NOT_REACHED; /* NOTREACHED */
2629
2630         case MDEREF_HV_gvhv_helem:
2631             is_hash = TRUE;
2632             /* FALLTHROUGH */
2633         case MDEREF_AV_gvav_aelem:
2634             derefs = 1;
2635             items++;
2636             sv = ITEM_SV(items);
2637             S_append_gv_name(aTHX_ (GV*)sv, out);
2638             goto do_elem;
2639             NOT_REACHED; /* NOTREACHED */
2640
2641         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2642             is_hash = TRUE;
2643             /* FALLTHROUGH */
2644         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2645             items++;
2646             sv = ITEM_SV(items);
2647             S_append_gv_name(aTHX_ (GV*)sv, out);
2648             goto do_vivify_rv2xv_elem;
2649             NOT_REACHED; /* NOTREACHED */
2650
2651         case MDEREF_HV_padsv_vivify_rv2hv_helem:
2652             is_hash = TRUE;
2653             /* FALLTHROUGH */
2654         case MDEREF_AV_padsv_vivify_rv2av_aelem:
2655             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2656             goto do_vivify_rv2xv_elem;
2657             NOT_REACHED; /* NOTREACHED */
2658
2659         case MDEREF_HV_pop_rv2hv_helem:
2660         case MDEREF_HV_vivify_rv2hv_helem:
2661             is_hash = TRUE;
2662             /* FALLTHROUGH */
2663         do_vivify_rv2xv_elem:
2664         case MDEREF_AV_pop_rv2av_aelem:
2665         case MDEREF_AV_vivify_rv2av_aelem:
2666             if (!derefs++)
2667                 sv_catpvs_nomg(out, "->");
2668         do_elem:
2669             if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2670                 sv_catpvs_nomg(out, "->");
2671                 last = 1;
2672                 break;
2673             }
2674
2675             sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2676             switch (actions & MDEREF_INDEX_MASK) {
2677             case MDEREF_INDEX_const:
2678                 if (is_hash) {
2679                     items++;
2680                     sv = ITEM_SV(items);
2681                     if (!sv)
2682                         sv_catpvs_nomg(out, "???");
2683                     else {
2684                         STRLEN cur;
2685                         char *s;
2686                         s = SvPV(sv, cur);
2687                         pv_pretty(out, s, cur, 30,
2688                                     NULL, NULL,
2689                                     (PERL_PV_PRETTY_NOCLEAR
2690                                     |PERL_PV_PRETTY_QUOTE
2691                                     |PERL_PV_PRETTY_ELLIPSES));
2692                     }
2693                 }
2694                 else
2695                     Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2696                 break;
2697             case MDEREF_INDEX_padsv:
2698                 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2699                 break;
2700             case MDEREF_INDEX_gvsv:
2701                 items++;
2702                 sv = ITEM_SV(items);
2703                 S_append_gv_name(aTHX_ (GV*)sv, out);
2704                 break;
2705             }
2706             sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2707
2708             if (actions & MDEREF_FLAG_last)
2709                 last = 1;
2710             is_hash = FALSE;
2711
2712             break;
2713
2714         default:
2715             PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2716                 (int)(actions & MDEREF_ACTION_MASK));
2717             last = 1;
2718             break;
2719
2720         } /* switch */
2721
2722         actions >>= MDEREF_SHIFT;
2723     } /* while */
2724     return out;
2725 }
2726
2727
2728 I32
2729 Perl_debop(pTHX_ const OP *o)
2730 {
2731     PERL_ARGS_ASSERT_DEBOP;
2732
2733     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2734         return 0;
2735
2736     Perl_deb(aTHX_ "%s", OP_NAME(o));
2737     switch (o->op_type) {
2738     case OP_CONST:
2739     case OP_HINTSEVAL:
2740         /* With ITHREADS, consts are stored in the pad, and the right pad
2741          * may not be active here, so check.
2742          * Looks like only during compiling the pads are illegal.
2743          */
2744 #ifdef USE_ITHREADS
2745         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2746 #endif
2747             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2748         break;
2749     case OP_GVSV:
2750     case OP_GV:
2751         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2752                 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
2753         break;
2754
2755     case OP_PADSV:
2756     case OP_PADAV:
2757     case OP_PADHV:
2758     case OP_ARGELEM:
2759         S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2760         break;
2761
2762     case OP_PADRANGE:
2763         S_deb_padvar(aTHX_ o->op_targ,
2764                         o->op_private & OPpPADRANGE_COUNTMASK, 1);
2765         break;
2766
2767     case OP_MULTIDEREF:
2768         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2769             SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2770         break;
2771
2772     default:
2773         break;
2774     }
2775     PerlIO_printf(Perl_debug_log, "\n");
2776     return 0;
2777 }
2778
2779
2780 /*
2781 =for apidoc op_class
2782
2783 Given an op, determine what type of struct it has been allocated as.
2784 Returns one of the OPclass enums, such as OPclass_LISTOP.
2785
2786 =cut
2787 */
2788
2789
2790 OPclass
2791 Perl_op_class(pTHX_ const OP *o)
2792 {
2793     bool custom = 0;
2794
2795     if (!o)
2796         return OPclass_NULL;
2797
2798     if (o->op_type == 0) {
2799         if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2800             return OPclass_COP;
2801         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2802     }
2803
2804     if (o->op_type == OP_SASSIGN)
2805         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2806
2807     if (o->op_type == OP_AELEMFAST) {
2808 #ifdef USE_ITHREADS
2809             return OPclass_PADOP;
2810 #else
2811             return OPclass_SVOP;
2812 #endif
2813     }
2814     
2815 #ifdef USE_ITHREADS
2816     if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2817         o->op_type == OP_RCATLINE)
2818         return OPclass_PADOP;
2819 #endif
2820
2821     if (o->op_type == OP_CUSTOM)
2822         custom = 1;
2823
2824     switch (OP_CLASS(o)) {
2825     case OA_BASEOP:
2826         return OPclass_BASEOP;
2827
2828     case OA_UNOP:
2829         return OPclass_UNOP;
2830
2831     case OA_BINOP:
2832         return OPclass_BINOP;
2833
2834     case OA_LOGOP:
2835         return OPclass_LOGOP;
2836
2837     case OA_LISTOP:
2838         return OPclass_LISTOP;
2839
2840     case OA_PMOP:
2841         return OPclass_PMOP;
2842
2843     case OA_SVOP:
2844         return OPclass_SVOP;
2845
2846     case OA_PADOP:
2847         return OPclass_PADOP;
2848
2849     case OA_PVOP_OR_SVOP:
2850         /*
2851          * Character translations (tr///) are usually a PVOP, keeping a 
2852          * pointer to a table of shorts used to look up translations.
2853          * Under utf8, however, a simple table isn't practical; instead,
2854          * the OP is an SVOP (or, under threads, a PADOP),
2855          * and the SV is a reference to a swash
2856          * (i.e., an RV pointing to an HV).
2857          */
2858         return (!custom &&
2859                    (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2860                )
2861 #if  defined(USE_ITHREADS)
2862                 ? OPclass_PADOP : OPclass_PVOP;
2863 #else
2864                 ? OPclass_SVOP : OPclass_PVOP;
2865 #endif
2866
2867     case OA_LOOP:
2868         return OPclass_LOOP;
2869
2870     case OA_COP:
2871         return OPclass_COP;
2872
2873     case OA_BASEOP_OR_UNOP:
2874         /*
2875          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2876          * whether parens were seen. perly.y uses OPf_SPECIAL to
2877          * signal whether a BASEOP had empty parens or none.
2878          * Some other UNOPs are created later, though, so the best
2879          * test is OPf_KIDS, which is set in newUNOP.
2880          */
2881         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2882
2883     case OA_FILESTATOP:
2884         /*
2885          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2886          * the OPf_REF flag to distinguish between OP types instead of the
2887          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2888          * return OPclass_UNOP so that walkoptree can find our children. If
2889          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2890          * (no argument to the operator) it's an OP; with OPf_REF set it's
2891          * an SVOP (and op_sv is the GV for the filehandle argument).
2892          */
2893         return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2894 #ifdef USE_ITHREADS
2895                 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2896 #else
2897                 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
2898 #endif
2899     case OA_LOOPEXOP:
2900         /*
2901          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
2902          * label was omitted (in which case it's a BASEOP) or else a term was
2903          * seen. In this last case, all except goto are definitely PVOP but
2904          * goto is either a PVOP (with an ordinary constant label), an UNOP
2905          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
2906          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
2907          * get set.
2908          */
2909         if (o->op_flags & OPf_STACKED)
2910             return OPclass_UNOP;
2911         else if (o->op_flags & OPf_SPECIAL)
2912             return OPclass_BASEOP;
2913         else
2914             return OPclass_PVOP;
2915     case OA_METHOP:
2916         return OPclass_METHOP;
2917     case OA_UNOP_AUX:
2918         return OPclass_UNOP_AUX;
2919     }
2920     Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
2921          OP_NAME(o));
2922     return OPclass_BASEOP;
2923 }
2924
2925
2926
2927 STATIC CV*
2928 S_deb_curcv(pTHX_ I32 ix)
2929 {
2930     PERL_SI *si = PL_curstackinfo;
2931     for (; ix >=0; ix--) {
2932         const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2933
2934         if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2935             return cx->blk_sub.cv;
2936         else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2937             return cx->blk_eval.cv;
2938         else if (ix == 0 && si->si_type == PERLSI_MAIN)
2939             return PL_main_cv;
2940         else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2941                && si->si_type == PERLSI_SORT)
2942         {
2943             /* fake sort sub; use CV of caller */
2944             si = si->si_prev;
2945             ix = si->si_cxix + 1;
2946         }
2947     }
2948     return NULL;
2949 }
2950
2951 void
2952 Perl_watch(pTHX_ char **addr)
2953 {
2954     PERL_ARGS_ASSERT_WATCH;
2955
2956     PL_watchaddr = addr;
2957     PL_watchok = *addr;
2958     PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
2959         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2960 }
2961
2962 STATIC void
2963 S_debprof(pTHX_ const OP *o)
2964 {
2965     PERL_ARGS_ASSERT_DEBPROF;
2966
2967     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2968         return;
2969     if (!PL_profiledata)
2970         Newxz(PL_profiledata, MAXO, U32);
2971     ++PL_profiledata[o->op_type];
2972 }
2973
2974 void
2975 Perl_debprofdump(pTHX)
2976 {
2977     unsigned i;
2978     if (!PL_profiledata)
2979         return;
2980     for (i = 0; i < MAXO; i++) {
2981         if (PL_profiledata[i])
2982             PerlIO_printf(Perl_debug_log,
2983                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2984                                        PL_op_name[i]);
2985     }
2986 }
2987
2988
2989 /*
2990  * ex: set ts=8 sts=4 sw=4 et:
2991  */