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