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