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