This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
1d24f351cc59f7f0966194537d4f6baae160be5d
[perl5.git] / dump.c
1 /*    dump.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *  'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13  *   it has not been hard for me to read your mind and memory.'
14  *
15  *     [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
16  */
17
18 /* This file contains utility routines to dump the contents of SV and OP
19  * structures, as used by command-line options like -Dt and -Dx, and
20  * by Devel::Peek.
21  *
22  * It also holds the debugging version of the  runops function.
23  */
24
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 chars above 127 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           || (( u > 127 ) && (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 bytes in the range
339                128-255 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 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         I32 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_FOLDED, ",FOLDED"},
748     {OPpCONST_BARE, ",BARE"}
749 };
750
751 const struct flag_to_name op_sort_names[] = {
752     {OPpSORT_NUMERIC, ",NUMERIC"},
753     {OPpSORT_INTEGER, ",INTEGER"},
754     {OPpSORT_REVERSE, ",REVERSE"},
755     {OPpSORT_INPLACE, ",INPLACE"},
756     {OPpSORT_DESCEND, ",DESCEND"},
757     {OPpSORT_QSORT, ",QSORT"},
758     {OPpSORT_STABLE, ",STABLE"}
759 };
760
761 const struct flag_to_name op_open_names[] = {
762     {OPpOPEN_IN_RAW, ",IN_RAW"},
763     {OPpOPEN_IN_CRLF, ",IN_CRLF"},
764     {OPpOPEN_OUT_RAW, ",OUT_RAW"},
765     {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
766 };
767
768 const struct flag_to_name op_exit_names[] = {
769     {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
770     {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
771 };
772
773 const struct flag_to_name op_sassign_names[] = {
774     {OPpASSIGN_BACKWARDS, ",BACKWARDS"},
775     {OPpASSIGN_CV_TO_GV,  ",CV2GV"}
776 };
777
778 #define OP_PRIVATE_ONCE(op, flag, name) \
779     const struct flag_to_name CAT2(op, _names)[] = {    \
780         {(flag), (name)} \
781     }
782
783 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
784 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
785 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
786 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
787 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
788 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
789 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
790 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
791 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
792 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
793 OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM");
794
795 struct op_private_by_op {
796     U16 op_type;
797     U16 len;
798     const struct flag_to_name *start;
799 };
800
801 const struct op_private_by_op op_private_names[] = {
802     {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803     {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
804     {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
805     {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
806     {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
807     {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
808     {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
809     {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
810     {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
811     {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
812     {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
813     {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
814     {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
815     {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
816     {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
817     {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
818     {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
819     {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
820     {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
821     {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names },
822     {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
823 };
824
825 static bool
826 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
827     const struct op_private_by_op *start = op_private_names;
828     const struct op_private_by_op *const end
829         = op_private_names + C_ARRAY_LENGTH(op_private_names);
830
831     /* This is a linear search, but no worse than the code that it replaced.
832        It's debugging code - size is more important than speed.  */
833     do {
834         if (optype == start->op_type) {
835             S_append_flags(aTHX_ tmpsv, op_private, start->start,
836                            start->start + start->len);
837             return TRUE;
838         }
839     } while (++start < end);
840     return FALSE;
841 }
842
843 #define DUMP_OP_FLAGS(o,xml,level,file)                                 \
844     if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \
845         SV * const tmpsv = newSVpvs("");                                \
846         switch (o->op_flags & OPf_WANT) {                               \
847         case OPf_WANT_VOID:                                             \
848             sv_catpv(tmpsv, ",VOID");                                   \
849             break;                                                      \
850         case OPf_WANT_SCALAR:                                           \
851             sv_catpv(tmpsv, ",SCALAR");                                 \
852             break;                                                      \
853         case OPf_WANT_LIST:                                             \
854             sv_catpv(tmpsv, ",LIST");                                   \
855             break;                                                      \
856         default:                                                        \
857             sv_catpv(tmpsv, ",UNKNOWN");                                \
858             break;                                                      \
859         }                                                               \
860         append_flags(tmpsv, o->op_flags, op_flags_names);               \
861         if (o->op_slabbed)  sv_catpvs(tmpsv, ",SLABBED");               \
862         if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");              \
863         if (o->op_static)   sv_catpvs(tmpsv, ",STATIC");                \
864         if (o->op_folded)   sv_catpvs(tmpsv, ",FOLDED");                \
865         if (!xml)                                                        \
866             Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",       \
867                             SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\
868         else                                                            \
869             PerlIO_printf(file, " flags=\"%s\"",                        \
870                           SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");        \
871         SvREFCNT_dec_NN(tmpsv);                                            \
872     }
873
874 #if !defined(PERL_MAD)
875 # define xmldump_attr1(level, file, pat, arg)
876 #else
877 # define xmldump_attr1(level, file, pat, arg) \
878         S_xmldump_attr(aTHX_ level, file, pat, arg)
879 #endif
880
881 #define DUMP_OP_PRIVATE(o,xml,level,file)                               \
882     if (o->op_private) {                                                \
883         U32 optype = o->op_type;                                        \
884         U32 oppriv = o->op_private;                                     \
885         SV * const tmpsv = newSVpvs("");                                \
886         if (PL_opargs[optype] & OA_TARGLEX) {                           \
887             if (oppriv & OPpTARGET_MY)                                  \
888                 sv_catpv(tmpsv, ",TARGET_MY");                          \
889         }                                                               \
890         else if (optype == OP_ENTERSUB ||                               \
891                  optype == OP_RV2SV ||                                  \
892                  optype == OP_GVSV ||                                   \
893                  optype == OP_RV2AV ||                                  \
894                  optype == OP_RV2HV ||                                  \
895                  optype == OP_RV2GV ||                                  \
896                  optype == OP_AELEM ||                                  \
897                  optype == OP_HELEM )                                   \
898         {                                                               \
899             if (optype == OP_ENTERSUB) {                                \
900                 append_flags(tmpsv, oppriv, op_entersub_names);         \
901             }                                                           \
902             else {                                                      \
903                 switch (oppriv & OPpDEREF) {                            \
904                 case OPpDEREF_SV:                                       \
905                     sv_catpv(tmpsv, ",SV");                             \
906                     break;                                              \
907                 case OPpDEREF_AV:                                       \
908                     sv_catpv(tmpsv, ",AV");                             \
909                     break;                                              \
910                 case OPpDEREF_HV:                                       \
911                     sv_catpv(tmpsv, ",HV");                             \
912                     break;                                              \
913                 }                                                       \
914                 if (oppriv & OPpMAYBE_LVSUB)                            \
915                     sv_catpv(tmpsv, ",MAYBE_LVSUB");                    \
916             }                                                           \
917             if (optype == OP_AELEM || optype == OP_HELEM) {             \
918                 if (oppriv & OPpLVAL_DEFER)                             \
919                     sv_catpv(tmpsv, ",LVAL_DEFER");                     \
920             }                                                           \
921             else if (optype == OP_RV2HV || optype == OP_PADHV) {        \
922                 if (oppriv & OPpMAYBE_TRUEBOOL)                         \
923                     sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL");             \
924                 if (oppriv & OPpTRUEBOOL)                               \
925                     sv_catpvs(tmpsv, ",OPpTRUEBOOL");                   \
926             }                                                           \
927             else {                                                      \
928                 if (oppriv & HINT_STRICT_REFS)                          \
929                     sv_catpv(tmpsv, ",STRICT_REFS");                    \
930                 if (oppriv & OPpOUR_INTRO)                              \
931                     sv_catpv(tmpsv, ",OUR_INTRO");                      \
932             }                                                           \
933         }                                                               \
934         else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) {  \
935         }                                                               \
936         else if (OP_IS_FILETEST(o->op_type)) {                          \
937             if (oppriv & OPpFT_ACCESS)                                  \
938                 sv_catpv(tmpsv, ",FT_ACCESS");                          \
939             if (oppriv & OPpFT_STACKED)                                 \
940                 sv_catpv(tmpsv, ",FT_STACKED");                         \
941             if (oppriv & OPpFT_STACKING)                                \
942                 sv_catpv(tmpsv, ",FT_STACKING");                        \
943             if (oppriv & OPpFT_AFTER_t)                                 \
944                 sv_catpv(tmpsv, ",AFTER_t");                            \
945         }                                                               \
946         else if (o->op_type == OP_AASSIGN) {                            \
947             if (oppriv & OPpASSIGN_COMMON)                              \
948                 sv_catpvs(tmpsv, ",COMMON");                            \
949             if (oppriv & OPpMAYBE_LVSUB)                                \
950                 sv_catpvs(tmpsv, ",MAYBE_LVSUB");                       \
951         }                                                               \
952         if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO)            \
953             sv_catpv(tmpsv, ",INTRO");                                  \
954         if (o->op_type == OP_PADRANGE)                                  \
955             Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf,                 \
956                            (UV)(oppriv & OPpPADRANGE_COUNTMASK));       \
957         if (SvCUR(tmpsv)) {                                             \
958             if (xml)                                                    \
959                 xmldump_attr1(level+1, file, "private=\"%s\"", SvPVX(tmpsv)+1); \
960             else                                                        \
961                 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \
962         } else if (!xml)                                                \
963             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \
964                              (UV)oppriv);                               \
965         SvREFCNT_dec_NN(tmpsv);                                         \
966     }
967
968
969 void
970 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
971 {
972     dVAR;
973     UV      seq;
974     const OPCODE optype = o->op_type;
975
976     PERL_ARGS_ASSERT_DO_OP_DUMP;
977
978     Perl_dump_indent(aTHX_ level, file, "{\n");
979     level++;
980     seq = sequence_num(o);
981     if (seq)
982         PerlIO_printf(file, "%-4"UVuf, seq);
983     else
984         PerlIO_printf(file, "????");
985     PerlIO_printf(file,
986                   "%*sTYPE = %s  ===> ",
987                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
988     if (o->op_next)
989         PerlIO_printf(file,
990                         o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
991                                 sequence_num(o->op_next));
992     else
993         PerlIO_printf(file, "NULL\n");
994     if (o->op_targ) {
995         if (optype == OP_NULL) {
996             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
997             if (o->op_targ == OP_NEXTSTATE) {
998                 if (CopLINE(cCOPo))
999                     Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1000                                      (UV)CopLINE(cCOPo));
1001                 if (CopSTASHPV(cCOPo))
1002                     Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1003                                      CopSTASHPV(cCOPo));
1004                 if (CopLABEL(cCOPo))
1005                     Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1006                                      CopLABEL(cCOPo));
1007             }
1008         }
1009         else
1010             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
1011     }
1012 #ifdef DUMPADDR
1013     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
1014 #endif
1015
1016     DUMP_OP_FLAGS(o,0,level,file);
1017     DUMP_OP_PRIVATE(o,0,level,file);
1018
1019 #ifdef PERL_MAD
1020     if (PL_madskills && o->op_madprop) {
1021         SV * const tmpsv = newSVpvs("");
1022         MADPROP* mp = o->op_madprop;
1023         Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1024         level++;
1025         while (mp) {
1026             const char tmp = mp->mad_key;
1027             sv_setpvs(tmpsv,"'");
1028             if (tmp)
1029                 sv_catpvn(tmpsv, &tmp, 1);
1030             sv_catpv(tmpsv, "'=");
1031             switch (mp->mad_type) {
1032             case MAD_NULL:
1033                 sv_catpv(tmpsv, "NULL");
1034                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1035                 break;
1036             case MAD_PV:
1037                 sv_catpv(tmpsv, "<");
1038                 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1039                 sv_catpv(tmpsv, ">");
1040                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1041                 break;
1042             case MAD_OP:
1043                 if ((OP*)mp->mad_val) {
1044                     Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1045                     do_op_dump(level, file, (OP*)mp->mad_val);
1046                 }
1047                 break;
1048             default:
1049                 sv_catpv(tmpsv, "(UNK)");
1050                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1051                 break;
1052             }
1053             mp = mp->mad_next;
1054         }
1055         level--;
1056         Perl_dump_indent(aTHX_ level, file, "}\n");
1057
1058         SvREFCNT_dec_NN(tmpsv);
1059     }
1060 #endif
1061
1062     switch (optype) {
1063     case OP_AELEMFAST:
1064     case OP_GVSV:
1065     case OP_GV:
1066 #ifdef USE_ITHREADS
1067         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1068 #else
1069         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1070             if (cSVOPo->op_sv) {
1071                 SV * const tmpsv = newSV(0);
1072                 ENTER;
1073                 SAVEFREESV(tmpsv);
1074 #ifdef PERL_MAD
1075                 /* FIXME - is this making unwarranted assumptions about the
1076                    UTF-8 cleanliness of the dump file handle?  */
1077                 SvUTF8_on(tmpsv);
1078 #endif
1079                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1080                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1081                                  SvPV_nolen_const(tmpsv));
1082                 LEAVE;
1083             }
1084             else
1085                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1086         }
1087 #endif
1088         break;
1089     case OP_CONST:
1090     case OP_HINTSEVAL:
1091     case OP_METHOD_NAMED:
1092 #ifndef USE_ITHREADS
1093         /* with ITHREADS, consts are stored in the pad, and the right pad
1094          * may not be active here, so skip */
1095         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1096 #endif
1097         break;
1098     case OP_NEXTSTATE:
1099     case OP_DBSTATE:
1100         if (CopLINE(cCOPo))
1101             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1102                              (UV)CopLINE(cCOPo));
1103         if (CopSTASHPV(cCOPo))
1104             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1105                              CopSTASHPV(cCOPo));
1106         if (CopLABEL(cCOPo))
1107             Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1108                              CopLABEL(cCOPo));
1109         break;
1110     case OP_ENTERLOOP:
1111         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1112         if (cLOOPo->op_redoop)
1113             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1114         else
1115             PerlIO_printf(file, "DONE\n");
1116         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1117         if (cLOOPo->op_nextop)
1118             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1119         else
1120             PerlIO_printf(file, "DONE\n");
1121         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1122         if (cLOOPo->op_lastop)
1123             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1124         else
1125             PerlIO_printf(file, "DONE\n");
1126         break;
1127     case OP_COND_EXPR:
1128     case OP_RANGE:
1129     case OP_MAPWHILE:
1130     case OP_GREPWHILE:
1131     case OP_OR:
1132     case OP_AND:
1133         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1134         if (cLOGOPo->op_other)
1135             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1136         else
1137             PerlIO_printf(file, "DONE\n");
1138         break;
1139     case OP_PUSHRE:
1140     case OP_MATCH:
1141     case OP_QR:
1142     case OP_SUBST:
1143         do_pmop_dump(level, file, cPMOPo);
1144         break;
1145     case OP_LEAVE:
1146     case OP_LEAVEEVAL:
1147     case OP_LEAVESUB:
1148     case OP_LEAVESUBLV:
1149     case OP_LEAVEWRITE:
1150     case OP_SCOPE:
1151         if (o->op_private & OPpREFCOUNTED)
1152             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1153         break;
1154     default:
1155         break;
1156     }
1157     if (o->op_flags & OPf_KIDS) {
1158         OP *kid;
1159         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1160             do_op_dump(level, file, kid);
1161     }
1162     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1163 }
1164
1165 void
1166 Perl_op_dump(pTHX_ const OP *o)
1167 {
1168     PERL_ARGS_ASSERT_OP_DUMP;
1169     do_op_dump(0, Perl_debug_log, o);
1170 }
1171
1172 void
1173 Perl_gv_dump(pTHX_ GV *gv)
1174 {
1175     SV *sv;
1176
1177     PERL_ARGS_ASSERT_GV_DUMP;
1178
1179     if (!gv) {
1180         PerlIO_printf(Perl_debug_log, "{}\n");
1181         return;
1182     }
1183     sv = sv_newmortal();
1184     PerlIO_printf(Perl_debug_log, "{\n");
1185     gv_fullname3(sv, gv, NULL);
1186     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1187     if (gv != GvEGV(gv)) {
1188         gv_efullname3(sv, GvEGV(gv), NULL);
1189         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1190     }
1191     PerlIO_putc(Perl_debug_log, '\n');
1192     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1193 }
1194
1195
1196 /* map magic types to the symbolic names
1197  * (with the PERL_MAGIC_ prefixed stripped)
1198  */
1199
1200 static const struct { const char type; const char *name; } magic_names[] = {
1201 #include "mg_names.c"
1202         /* this null string terminates the list */
1203         { 0,                         NULL },
1204 };
1205
1206 void
1207 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1208 {
1209     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1210
1211     for (; mg; mg = mg->mg_moremagic) {
1212         Perl_dump_indent(aTHX_ level, file,
1213                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1214         if (mg->mg_virtual) {
1215             const MGVTBL * const v = mg->mg_virtual;
1216             if (v >= PL_magic_vtables
1217                 && v < PL_magic_vtables + magic_vtable_max) {
1218                 const U32 i = v - PL_magic_vtables;
1219                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1220             }
1221             else
1222                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1223         }
1224         else
1225             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1226
1227         if (mg->mg_private)
1228             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1229
1230         {
1231             int n;
1232             const char *name = NULL;
1233             for (n = 0; magic_names[n].name; n++) {
1234                 if (mg->mg_type == magic_names[n].type) {
1235                     name = magic_names[n].name;
1236                     break;
1237                 }
1238             }
1239             if (name)
1240                 Perl_dump_indent(aTHX_ level, file,
1241                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1242             else
1243                 Perl_dump_indent(aTHX_ level, file,
1244                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1245         }
1246
1247         if (mg->mg_flags) {
1248             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1249             if (mg->mg_type == PERL_MAGIC_envelem &&
1250                 mg->mg_flags & MGf_TAINTEDDIR)
1251                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1252             if (mg->mg_type == PERL_MAGIC_regex_global &&
1253                 mg->mg_flags & MGf_MINMATCH)
1254                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1255             if (mg->mg_flags & MGf_REFCOUNTED)
1256                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1257             if (mg->mg_flags & MGf_GSKIP)
1258                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1259             if (mg->mg_flags & MGf_COPY)
1260                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1261             if (mg->mg_flags & MGf_DUP)
1262                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1263             if (mg->mg_flags & MGf_LOCAL)
1264                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1265         }
1266         if (mg->mg_obj) {
1267             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1268                 PTR2UV(mg->mg_obj));
1269             if (mg->mg_type == PERL_MAGIC_qr) {
1270                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1271                 SV * const dsv = sv_newmortal();
1272                 const char * const s
1273                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1274                     60, NULL, NULL,
1275                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1276                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1277                 );
1278                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1279                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1280                         (IV)RX_REFCNT(re));
1281             }
1282             if (mg->mg_flags & MGf_REFCOUNTED)
1283                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1284         }
1285         if (mg->mg_len)
1286             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1287         if (mg->mg_ptr) {
1288             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1289             if (mg->mg_len >= 0) {
1290                 if (mg->mg_type != PERL_MAGIC_utf8) {
1291                     SV * const sv = newSVpvs("");
1292                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1293                     SvREFCNT_dec_NN(sv);
1294                 }
1295             }
1296             else if (mg->mg_len == HEf_SVKEY) {
1297                 PerlIO_puts(file, " => HEf_SVKEY\n");
1298                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1299                            maxnest, dumpops, pvlim); /* MG is already +1 */
1300                 continue;
1301             }
1302             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1303             else
1304                 PerlIO_puts(
1305                   file,
1306                  " ???? - " __FILE__
1307                  " does not know how to handle this MG_LEN"
1308                 );
1309             PerlIO_putc(file, '\n');
1310         }
1311         if (mg->mg_type == PERL_MAGIC_utf8) {
1312             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1313             if (cache) {
1314                 IV i;
1315                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1316                     Perl_dump_indent(aTHX_ level, file,
1317                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1318                                      i,
1319                                      (UV)cache[i * 2],
1320                                      (UV)cache[i * 2 + 1]);
1321             }
1322         }
1323     }
1324 }
1325
1326 void
1327 Perl_magic_dump(pTHX_ const MAGIC *mg)
1328 {
1329     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1330 }
1331
1332 void
1333 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1334 {
1335     const char *hvname;
1336
1337     PERL_ARGS_ASSERT_DO_HV_DUMP;
1338
1339     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1340     if (sv && (hvname = HvNAME_get(sv)))
1341     {
1342         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1343            name which quite legally could contain insane things like tabs, newlines, nulls or
1344            other scary crap - this should produce sane results - except maybe for unicode package
1345            names - but we will wait for someone to file a bug on that - demerphq */
1346         SV * const tmpsv = newSVpvs("");
1347         PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1348     }
1349     else
1350         PerlIO_putc(file, '\n');
1351 }
1352
1353 void
1354 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1355 {
1356     PERL_ARGS_ASSERT_DO_GV_DUMP;
1357
1358     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1359     if (sv && GvNAME(sv))
1360         PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1361     else
1362         PerlIO_putc(file, '\n');
1363 }
1364
1365 void
1366 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1367 {
1368     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1369
1370     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1371     if (sv && GvNAME(sv)) {
1372         const char *hvname;
1373         PerlIO_printf(file, "\t\"");
1374         if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1375             PerlIO_printf(file, "%s\" :: \"", hvname);
1376         PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1377     }
1378     else
1379         PerlIO_putc(file, '\n');
1380 }
1381
1382 const struct flag_to_name first_sv_flags_names[] = {
1383     {SVs_TEMP, "TEMP,"},
1384     {SVs_OBJECT, "OBJECT,"},
1385     {SVs_GMG, "GMG,"},
1386     {SVs_SMG, "SMG,"},
1387     {SVs_RMG, "RMG,"},
1388     {SVf_IOK, "IOK,"},
1389     {SVf_NOK, "NOK,"},
1390     {SVf_POK, "POK,"}
1391 };
1392
1393 const struct flag_to_name second_sv_flags_names[] = {
1394     {SVf_OOK, "OOK,"},
1395     {SVf_FAKE, "FAKE,"},
1396     {SVf_READONLY, "READONLY,"},
1397     {SVf_IsCOW, "IsCOW,"},
1398     {SVf_BREAK, "BREAK,"},
1399     {SVf_AMAGIC, "OVERLOAD,"},
1400     {SVp_IOK, "pIOK,"},
1401     {SVp_NOK, "pNOK,"},
1402     {SVp_POK, "pPOK,"}
1403 };
1404
1405 const struct flag_to_name cv_flags_names[] = {
1406     {CVf_ANON, "ANON,"},
1407     {CVf_UNIQUE, "UNIQUE,"},
1408     {CVf_CLONE, "CLONE,"},
1409     {CVf_CLONED, "CLONED,"},
1410     {CVf_CONST, "CONST,"},
1411     {CVf_NODEBUG, "NODEBUG,"},
1412     {CVf_LVALUE, "LVALUE,"},
1413     {CVf_METHOD, "METHOD,"},
1414     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1415     {CVf_CVGV_RC, "CVGV_RC,"},
1416     {CVf_DYNFILE, "DYNFILE,"},
1417     {CVf_AUTOLOAD, "AUTOLOAD,"},
1418     {CVf_HASEVAL, "HASEVAL"},
1419     {CVf_SLABBED, "SLABBED,"},
1420     {CVf_ISXSUB, "ISXSUB,"}
1421 };
1422
1423 const struct flag_to_name hv_flags_names[] = {
1424     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1425     {SVphv_LAZYDEL, "LAZYDEL,"},
1426     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1427     {SVphv_CLONEABLE, "CLONEABLE,"}
1428 };
1429
1430 const struct flag_to_name gp_flags_names[] = {
1431     {GVf_INTRO, "INTRO,"},
1432     {GVf_MULTI, "MULTI,"},
1433     {GVf_ASSUMECV, "ASSUMECV,"},
1434     {GVf_IN_PAD, "IN_PAD,"}
1435 };
1436
1437 const struct flag_to_name gp_flags_imported_names[] = {
1438     {GVf_IMPORTED_SV, " SV"},
1439     {GVf_IMPORTED_AV, " AV"},
1440     {GVf_IMPORTED_HV, " HV"},
1441     {GVf_IMPORTED_CV, " CV"},
1442 };
1443
1444 const struct flag_to_name regexp_flags_names[] = {
1445     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1446     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1447     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1448     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1449     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1450     {RXf_ANCH_BOL,        "ANCH_BOL,"},
1451     {RXf_ANCH_MBOL,       "ANCH_MBOL,"},
1452     {RXf_ANCH_SBOL,       "ANCH_SBOL,"},
1453     {RXf_ANCH_GPOS,       "ANCH_GPOS,"},
1454     {RXf_GPOS_SEEN,       "GPOS_SEEN,"},
1455     {RXf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1456     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1457     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1458     {RXf_CANY_SEEN,       "CANY_SEEN,"},
1459     {RXf_NOSCAN,          "NOSCAN,"},
1460     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1461     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1462     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1463     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1464     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1465     {RXf_SPLIT,           "SPLIT,"},
1466     {RXf_COPY_DONE,       "COPY_DONE,"},
1467     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1468     {RXf_TAINTED,         "TAINTED,"},
1469     {RXf_START_ONLY,      "START_ONLY,"},
1470     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1471     {RXf_WHITE,           "WHITE,"},
1472     {RXf_NULL,            "NULL,"},
1473 };
1474
1475 void
1476 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1477 {
1478     dVAR;
1479     SV *d;
1480     const char *s;
1481     U32 flags;
1482     U32 type;
1483
1484     PERL_ARGS_ASSERT_DO_SV_DUMP;
1485
1486     if (!sv) {
1487         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1488         return;
1489     }
1490
1491     flags = SvFLAGS(sv);
1492     type = SvTYPE(sv);
1493
1494     /* process general SV flags */
1495
1496     d = Perl_newSVpvf(aTHX_
1497                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1498                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1499                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1500                    (int)(PL_dumpindent*level), "");
1501
1502     if (!((flags & SVpad_NAME) == SVpad_NAME
1503           && (type == SVt_PVMG || type == SVt_PVNV))) {
1504         if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1505             sv_catpv(d, "PADSTALE,");
1506     }
1507     if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1508         if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1509             sv_catpv(d, "PADTMP,");
1510         if (flags & SVs_PADMY)  sv_catpv(d, "PADMY,");
1511     }
1512     append_flags(d, flags, first_sv_flags_names);
1513     if (flags & SVf_ROK)  {     
1514                                 sv_catpv(d, "ROK,");
1515         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1516     }
1517     append_flags(d, flags, second_sv_flags_names);
1518     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1519                            && type != SVt_PVAV) {
1520         if (SvPCS_IMPORTED(sv))
1521                                 sv_catpv(d, "PCS_IMPORTED,");
1522         else
1523                                 sv_catpv(d, "SCREAM,");
1524     }
1525
1526     /* process type-specific SV flags */
1527
1528     switch (type) {
1529     case SVt_PVCV:
1530     case SVt_PVFM:
1531         append_flags(d, CvFLAGS(sv), cv_flags_names);
1532         break;
1533     case SVt_PVHV:
1534         append_flags(d, flags, hv_flags_names);
1535         break;
1536     case SVt_PVGV:
1537     case SVt_PVLV:
1538         if (isGV_with_GP(sv)) {
1539             append_flags(d, GvFLAGS(sv), gp_flags_names);
1540         }
1541         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1542             sv_catpv(d, "IMPORT");
1543             if (GvIMPORTED(sv) == GVf_IMPORTED)
1544                 sv_catpv(d, "ALL,");
1545             else {
1546                 sv_catpv(d, "(");
1547                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1548                 sv_catpv(d, " ),");
1549             }
1550         }
1551         /* FALL THROUGH */
1552     default:
1553     evaled_or_uv:
1554         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1555         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1556         break;
1557     case SVt_PVMG:
1558         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1559         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1560         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1561         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1562         /* FALL THROUGH */
1563     case SVt_PVNV:
1564         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1565         goto evaled_or_uv;
1566     case SVt_PVAV:
1567         if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
1568         break;
1569     }
1570     /* SVphv_SHAREKEYS is also 0x20000000 */
1571     if ((type != SVt_PVHV) && SvUTF8(sv))
1572         sv_catpv(d, "UTF8");
1573
1574     if (*(SvEND(d) - 1) == ',') {
1575         SvCUR_set(d, SvCUR(d) - 1);
1576         SvPVX(d)[SvCUR(d)] = '\0';
1577     }
1578     sv_catpv(d, ")");
1579     s = SvPVX_const(d);
1580
1581     /* dump initial SV details */
1582
1583 #ifdef DEBUG_LEAKING_SCALARS
1584     Perl_dump_indent(aTHX_ level, file,
1585         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1586         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1587         sv->sv_debug_line,
1588         sv->sv_debug_inpad ? "for" : "by",
1589         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1590         PTR2UV(sv->sv_debug_parent),
1591         sv->sv_debug_serial
1592     );
1593 #endif
1594     Perl_dump_indent(aTHX_ level, file, "SV = ");
1595
1596     /* Dump SV type */
1597
1598     if (type < SVt_LAST) {
1599         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1600
1601         if (type ==  SVt_NULL) {
1602             SvREFCNT_dec_NN(d);
1603             return;
1604         }
1605     } else {
1606         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1607         SvREFCNT_dec_NN(d);
1608         return;
1609     }
1610
1611     /* Dump general SV fields */
1612
1613     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1614          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1615          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1616         || (type == SVt_IV && !SvROK(sv))) {
1617         if (SvIsUV(sv)
1618 #ifdef PERL_OLD_COPY_ON_WRITE
1619                        || SvIsCOW(sv)
1620 #endif
1621                                      )
1622             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1623         else
1624             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1625 #ifdef PERL_OLD_COPY_ON_WRITE
1626         if (SvIsCOW_shared_hash(sv))
1627             PerlIO_printf(file, "  (HASH)");
1628         else if (SvIsCOW_normal(sv))
1629             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1630 #endif
1631         PerlIO_putc(file, '\n');
1632     }
1633
1634     if ((type == SVt_PVNV || type == SVt_PVMG)
1635         && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1636         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1637                          (UV) COP_SEQ_RANGE_LOW(sv));
1638         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1639                          (UV) COP_SEQ_RANGE_HIGH(sv));
1640     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1641                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1642                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1643                || type == SVt_NV) {
1644         STORE_NUMERIC_LOCAL_SET_STANDARD();
1645         /* %Vg doesn't work? --jhi */
1646 #ifdef USE_LONG_DOUBLE
1647         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1648 #else
1649         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1650 #endif
1651         RESTORE_NUMERIC_LOCAL();
1652     }
1653
1654     if (SvROK(sv)) {
1655         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1656         if (nest < maxnest)
1657             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1658     }
1659
1660     if (type < SVt_PV) {
1661         SvREFCNT_dec_NN(d);
1662         return;
1663     }
1664
1665     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1666      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1667         const bool re = isREGEXP(sv);
1668         const char * const ptr =
1669             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1670         if (ptr) {
1671             STRLEN delta;
1672             if (SvOOK(sv)) {
1673                 SvOOK_offset(sv, delta);
1674                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1675                                  (UV) delta);
1676             } else {
1677                 delta = 0;
1678             }
1679             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(ptr));
1680             if (SvOOK(sv)) {
1681                 PerlIO_printf(file, "( %s . ) ",
1682                               pv_display(d, ptr - delta, delta, 0,
1683                                          pvlim));
1684             }
1685             if (type == SVt_INVLIST) {
1686                 PerlIO_printf(file, "\n");
1687                 /* 4 blanks indents 2 beyond the PV, etc */
1688                 _invlist_dump(file, level, "    ", sv);
1689             }
1690             else {
1691                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1692                                                      re ? 0 : SvLEN(sv),
1693                                                      pvlim));
1694                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1695                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1696                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1697                                                         UNI_DISPLAY_QQ));
1698                 PerlIO_printf(file, "\n");
1699             }
1700             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1701             if (!re)
1702                 Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
1703                                        (IV)SvLEN(sv));
1704 #ifdef PERL_NEW_COPY_ON_WRITE
1705             if (SvIsCOW(sv) && SvLEN(sv))
1706                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1707                                        CowREFCNT(sv));
1708 #endif
1709         }
1710         else
1711             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1712     }
1713
1714     if (type >= SVt_PVMG) {
1715         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1716             HV * const ost = SvOURSTASH(sv);
1717             if (ost)
1718                 do_hv_dump(level, file, "  OURSTASH", ost);
1719         } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1720             Perl_dump_indent(aTHX_ level, file, "  MAXNAMED = %"UVuf"\n",
1721                                    (UV)PadnamelistMAXNAMED(sv));
1722         } else {
1723             if (SvMAGIC(sv))
1724                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1725         }
1726         if (SvSTASH(sv))
1727             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1728
1729         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1730             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1731         }
1732     }
1733
1734     /* Dump type-specific SV fields */
1735
1736     switch (type) {
1737     case SVt_PVAV:
1738         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1739         if (AvARRAY(sv) != AvALLOC(sv)) {
1740             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1741             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1742         }
1743         else
1744             PerlIO_putc(file, '\n');
1745         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1746         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1747         /* arylen is stored in magic, and padnamelists use SvMAGIC for
1748            something else. */
1749         if (!AvPAD_NAMELIST(sv))
1750             Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n",
1751                                    SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1752         sv_setpvs(d, "");
1753         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1754         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1755         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1756                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1757         if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1758             int count;
1759             for (count = 0; count <=  av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1760                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1761
1762                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1763                 if (elt)
1764                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1765             }
1766         }
1767         break;
1768     case SVt_PVHV:
1769         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1770         if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1771             /* Show distribution of HEs in the ARRAY */
1772             int freq[200];
1773 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1774             int i;
1775             int max = 0;
1776             U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1777             NV theoret, sum = 0;
1778
1779             PerlIO_printf(file, "  (");
1780             Zero(freq, FREQ_MAX + 1, int);
1781             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1782                 HE* h;
1783                 int count = 0;
1784                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1785                     count++;
1786                 if (count > FREQ_MAX)
1787                     count = FREQ_MAX;
1788                 freq[count]++;
1789                 if (max < count)
1790                     max = count;
1791             }
1792             for (i = 0; i <= max; i++) {
1793                 if (freq[i]) {
1794                     PerlIO_printf(file, "%d%s:%d", i,
1795                                   (i == FREQ_MAX) ? "+" : "",
1796                                   freq[i]);
1797                     if (i != max)
1798                         PerlIO_printf(file, ", ");
1799                 }
1800             }
1801             PerlIO_putc(file, ')');
1802             /* The "quality" of a hash is defined as the total number of
1803                comparisons needed to access every element once, relative
1804                to the expected number needed for a random hash.
1805
1806                The total number of comparisons is equal to the sum of
1807                the squares of the number of entries in each bucket.
1808                For a random hash of n keys into k buckets, the expected
1809                value is
1810                                 n + n(n-1)/2k
1811             */
1812
1813             for (i = max; i > 0; i--) { /* Precision: count down. */
1814                 sum += freq[i] * i * i;
1815             }
1816             while ((keys = keys >> 1))
1817                 pow2 = pow2 << 1;
1818             theoret = HvUSEDKEYS(sv);
1819             theoret += theoret * (theoret-1)/pow2;
1820             PerlIO_putc(file, '\n');
1821             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1822         }
1823         PerlIO_putc(file, '\n');
1824         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1825         {
1826             STRLEN count = 0;
1827             HE **ents = HvARRAY(sv);
1828
1829             if (ents) {
1830                 HE *const *const last = ents + HvMAX(sv);
1831                 count = last + 1 - ents;
1832                 
1833                 do {
1834                     if (!*ents)
1835                         --count;
1836                 } while (++ents <= last);
1837             }
1838
1839             if (SvOOK(sv)) {
1840                 struct xpvhv_aux *const aux = HvAUX(sv);
1841                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf
1842                                  " (cached = %"UVuf")\n",
1843                                  (UV)count, (UV)aux->xhv_fill_lazy);
1844             } else {
1845                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
1846                                  (UV)count);
1847             }
1848         }
1849         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1850         if (SvOOK(sv)) {
1851             Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1852             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1853 #ifdef PERL_HASH_RANDOMIZE_KEYS
1854             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1855             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1856                 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1857             }
1858 #endif
1859             PerlIO_putc(file, '\n');
1860         }
1861         {
1862             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1863             if (mg && mg->mg_obj) {
1864                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1865             }
1866         }
1867         {
1868             const char * const hvname = HvNAME_get(sv);
1869             if (hvname)
1870                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1871         }
1872         if (SvOOK(sv)) {
1873             AV * const backrefs
1874                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1875             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1876             if (HvAUX(sv)->xhv_name_count)
1877                 Perl_dump_indent(aTHX_
1878                  level, file, "  NAMECOUNT = %"IVdf"\n",
1879                  (IV)HvAUX(sv)->xhv_name_count
1880                 );
1881             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1882                 const I32 count = HvAUX(sv)->xhv_name_count;
1883                 if (count) {
1884                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1885                     /* The starting point is the first element if count is
1886                        positive and the second element if count is negative. */
1887                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1888                         + (count < 0 ? 1 : 0);
1889                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1890                         + (count < 0 ? -count : count);
1891                     while (hekp < endp) {
1892                         if (*hekp) {
1893                             sv_catpvs(names, ", \"");
1894                             sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1895                             sv_catpvs(names, "\"");
1896                         } else {
1897                             /* This should never happen. */
1898                             sv_catpvs(names, ", (null)");
1899                         }
1900                         ++hekp;
1901                     }
1902                     Perl_dump_indent(aTHX_
1903                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1904                     );
1905                 }
1906                 else
1907                     Perl_dump_indent(aTHX_
1908                      level, file, "  ENAME = \"%s\"\n", HvENAME_get(sv)
1909                     );
1910             }
1911             if (backrefs) {
1912                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1913                                  PTR2UV(backrefs));
1914                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1915                            dumpops, pvlim);
1916             }
1917             if (meta) {
1918                 /* FIXME - mro_algs kflags can signal a UTF-8 name.  */
1919                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1920                                  (int)meta->mro_which->length,
1921                                  meta->mro_which->name,
1922                                  PTR2UV(meta->mro_which));
1923                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1924                                  (UV)meta->cache_gen);
1925                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1926                                  (UV)meta->pkg_gen);
1927                 if (meta->mro_linear_all) {
1928                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1929                                  PTR2UV(meta->mro_linear_all));
1930                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1931                            dumpops, pvlim);
1932                 }
1933                 if (meta->mro_linear_current) {
1934                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1935                                  PTR2UV(meta->mro_linear_current));
1936                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1937                            dumpops, pvlim);
1938                 }
1939                 if (meta->mro_nextmethod) {
1940                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1941                                  PTR2UV(meta->mro_nextmethod));
1942                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1943                            dumpops, pvlim);
1944                 }
1945                 if (meta->isa) {
1946                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1947                                  PTR2UV(meta->isa));
1948                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1949                            dumpops, pvlim);
1950                 }
1951             }
1952         }
1953         if (nest < maxnest) {
1954             HV * const hv = MUTABLE_HV(sv);
1955             STRLEN i;
1956             HE *he;
1957
1958             if (HvARRAY(hv)) {
1959                 int count = maxnest - nest;
1960                 for (i=0; i <= HvMAX(hv); i++) {
1961                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1962                         U32 hash;
1963                         SV * keysv;
1964                         const char * keypv;
1965                         SV * elt;
1966                         STRLEN len;
1967
1968                         if (count-- <= 0) goto DONEHV;
1969
1970                         hash = HeHASH(he);
1971                         keysv = hv_iterkeysv(he);
1972                         keypv = SvPV_const(keysv, len);
1973                         elt = HeVAL(he);
1974
1975                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1976                         if (SvUTF8(keysv))
1977                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1978                         if (HvEITER_get(hv) == he)
1979                             PerlIO_printf(file, "[CURRENT] ");
1980                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1981                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1982                     }
1983                 }
1984               DONEHV:;
1985             }
1986         }
1987         break;
1988
1989     case SVt_PVCV:
1990         if (CvAUTOLOAD(sv)) {
1991             STRLEN len;
1992             const char *const name =  SvPV_const(sv, len);
1993             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%.*s\"\n",
1994                              (int) len, name);
1995         }
1996         if (SvPOK(sv)) {
1997             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1998                              (int) CvPROTOLEN(sv), CvPROTO(sv));
1999         }
2000         /* FALL THROUGH */
2001     case SVt_PVFM:
2002         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
2003         if (!CvISXSUB(sv)) {
2004             if (CvSTART(sv)) {
2005                 Perl_dump_indent(aTHX_ level, file,
2006                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
2007                                  PTR2UV(CvSTART(sv)),
2008                                  (IV)sequence_num(CvSTART(sv)));
2009             }
2010             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
2011                              PTR2UV(CvROOT(sv)));
2012             if (CvROOT(sv) && dumpops) {
2013                 do_op_dump(level+1, file, CvROOT(sv));
2014             }
2015         } else {
2016             SV * const constant = cv_const_sv((const CV *)sv);
2017
2018             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2019
2020             if (constant) {
2021                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
2022                                  " (CONST SV)\n",
2023                                  PTR2UV(CvXSUBANY(sv).any_ptr));
2024                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2025                            pvlim);
2026             } else {
2027                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
2028                                  (IV)CvXSUBANY(sv).any_i32);
2029             }
2030         }
2031         if (CvNAMED(sv))
2032             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2033                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
2034         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
2035         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
2036         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2037         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2038         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2039         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2040         if (nest < maxnest) {
2041             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2042         }
2043         {
2044             const CV * const outside = CvOUTSIDE(sv);
2045             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
2046                         PTR2UV(outside),
2047                         (!outside ? "null"
2048                          : CvANON(outside) ? "ANON"
2049                          : (outside == PL_main_cv) ? "MAIN"
2050                          : CvUNIQUE(outside) ? "UNIQUE"
2051                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2052         }
2053         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2054             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2055         break;
2056
2057     case SVt_PVGV:
2058     case SVt_PVLV:
2059         if (type == SVt_PVLV) {
2060             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2061             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2062             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2063             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2064             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2065             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2066                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2067                     dumpops, pvlim);
2068         }
2069         if (isREGEXP(sv)) goto dumpregexp;
2070         if (!isGV_with_GP(sv))
2071             break;
2072         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
2073         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2074         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2075         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2076         if (!GvGP(sv))
2077             break;
2078         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2079         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2080         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2081         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2082         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2083         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2084         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2085         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2086         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2087         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2088         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2089         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2090         break;
2091     case SVt_PVIO:
2092         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2093         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2094         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2095         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2096         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2097         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2098         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2099         if (IoTOP_NAME(sv))
2100             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2101         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2102             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2103         else {
2104             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2105                              PTR2UV(IoTOP_GV(sv)));
2106             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2107                         maxnest, dumpops, pvlim);
2108         }
2109         /* Source filters hide things that are not GVs in these three, so let's
2110            be careful out there.  */
2111         if (IoFMT_NAME(sv))
2112             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2113         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2114             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2115         else {
2116             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2117                              PTR2UV(IoFMT_GV(sv)));
2118             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2119                         maxnest, dumpops, pvlim);
2120         }
2121         if (IoBOTTOM_NAME(sv))
2122             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2123         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2124             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2125         else {
2126             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2127                              PTR2UV(IoBOTTOM_GV(sv)));
2128             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2129                         maxnest, dumpops, pvlim);
2130         }
2131         if (isPRINT(IoTYPE(sv)))
2132             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2133         else
2134             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2135         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2136         break;
2137     case SVt_REGEXP:
2138       dumpregexp:
2139         {
2140             struct regexp * const r = ReANY((REGEXP*)sv);
2141 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags) STMT_START { \
2142             sv_setpv(d,"");                                 \
2143             append_flags(d, flags, regexp_flags_names);     \
2144             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2145                 SvCUR_set(d, SvCUR(d) - 1);                 \
2146                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2147             }                                               \
2148 } STMT_END
2149             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags);
2150             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
2151                                 (UV)(r->compflags), SvPVX_const(d));
2152
2153             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags);
2154             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2155                                 (UV)(r->extflags), SvPVX_const(d));
2156 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2157
2158             Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2159                                 (UV)(r->intflags));
2160             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2161                                 (UV)(r->nparens));
2162             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2163                                 (UV)(r->lastparen));
2164             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2165                                 (UV)(r->lastcloseparen));
2166             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2167                                 (IV)(r->minlen));
2168             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2169                                 (IV)(r->minlenret));
2170             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2171                                 (UV)(r->gofs));
2172             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2173                                 (UV)(r->pre_prefix));
2174             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2175                                 (IV)(r->sublen));
2176             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
2177                                 (IV)(r->suboffset));
2178             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
2179                                 (IV)(r->subcoffset));
2180             if (r->subbeg)
2181                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2182                             PTR2UV(r->subbeg),
2183                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2184             else
2185                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2186             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf"\n",
2187                                 PTR2UV(r->engine));
2188             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2189                                 PTR2UV(r->mother_re));
2190             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2191                                 PTR2UV(r->paren_names));
2192             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2193                                 PTR2UV(r->substrs));
2194             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2195                                 PTR2UV(r->pprivate));
2196             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2197                                 PTR2UV(r->offs));
2198             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2199                                 PTR2UV(r->qr_anoncv));
2200 #ifdef PERL_ANY_COW
2201             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2202                                 PTR2UV(r->saved_copy));
2203 #endif
2204         }
2205         break;
2206     }
2207     SvREFCNT_dec_NN(d);
2208 }
2209
2210 void
2211 Perl_sv_dump(pTHX_ SV *sv)
2212 {
2213     dVAR;
2214
2215     PERL_ARGS_ASSERT_SV_DUMP;
2216
2217     if (SvROK(sv))
2218         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2219     else
2220         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2221 }
2222
2223 int
2224 Perl_runops_debug(pTHX)
2225 {
2226     dVAR;
2227     if (!PL_op) {
2228         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2229         return 0;
2230     }
2231
2232     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2233     do {
2234 #ifdef PERL_TRACE_OPS
2235         ++PL_op_exec_cnt[PL_op->op_type];
2236 #endif
2237         if (PL_debug) {
2238             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2239                 PerlIO_printf(Perl_debug_log,
2240                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2241                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2242                               PTR2UV(*PL_watchaddr));
2243             if (DEBUG_s_TEST_) {
2244                 if (DEBUG_v_TEST_) {
2245                     PerlIO_printf(Perl_debug_log, "\n");
2246                     deb_stack_all();
2247                 }
2248                 else
2249                     debstack();
2250             }
2251
2252
2253             if (DEBUG_t_TEST_) debop(PL_op);
2254             if (DEBUG_P_TEST_) debprof(PL_op);
2255         }
2256
2257         OP_ENTRY_PROBE(OP_NAME(PL_op));
2258     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2259     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2260     PERL_ASYNC_CHECK();
2261
2262     TAINT_NOT;
2263     return 0;
2264 }
2265
2266 I32
2267 Perl_debop(pTHX_ const OP *o)
2268 {
2269     dVAR;
2270
2271     PERL_ARGS_ASSERT_DEBOP;
2272
2273     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2274         return 0;
2275
2276     Perl_deb(aTHX_ "%s", OP_NAME(o));
2277     switch (o->op_type) {
2278     case OP_CONST:
2279     case OP_HINTSEVAL:
2280         /* With ITHREADS, consts are stored in the pad, and the right pad
2281          * may not be active here, so check.
2282          * Looks like only during compiling the pads are illegal.
2283          */
2284 #ifdef USE_ITHREADS
2285         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2286 #endif
2287             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2288         break;
2289     case OP_GVSV:
2290     case OP_GV:
2291         if (cGVOPo_gv) {
2292             SV * const sv = newSV(0);
2293 #ifdef PERL_MAD
2294             /* FIXME - is this making unwarranted assumptions about the
2295                UTF-8 cleanliness of the dump file handle?  */
2296             SvUTF8_on(sv);
2297 #endif
2298             gv_fullname3(sv, cGVOPo_gv, NULL);
2299             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2300             SvREFCNT_dec_NN(sv);
2301         }
2302         else
2303             PerlIO_printf(Perl_debug_log, "(NULL)");
2304         break;
2305
2306     {
2307         int count;
2308
2309     case OP_PADSV:
2310     case OP_PADAV:
2311     case OP_PADHV:
2312         count = 1;
2313         goto dump_padop;
2314     case OP_PADRANGE:
2315         count = o->op_private & OPpPADRANGE_COUNTMASK;
2316     dump_padop:
2317         /* print the lexical's name */
2318         {
2319             CV * const cv = deb_curcv(cxstack_ix);
2320             SV *sv;
2321             PAD * comppad = NULL;
2322             int i;
2323
2324             if (cv) {
2325                 PADLIST * const padlist = CvPADLIST(cv);
2326                 comppad = *PadlistARRAY(padlist);
2327             }
2328             PerlIO_printf(Perl_debug_log, "(");
2329             for (i = 0; i < count; i++) {
2330                 if (comppad &&
2331                         (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2332                     PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2333                 else
2334                     PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2335                             (UV)o->op_targ+i);
2336                 if (i < count-1)
2337                     PerlIO_printf(Perl_debug_log, ",");
2338             }
2339             PerlIO_printf(Perl_debug_log, ")");
2340         }
2341         break;
2342     }
2343
2344     default:
2345         break;
2346     }
2347     PerlIO_printf(Perl_debug_log, "\n");
2348     return 0;
2349 }
2350
2351 STATIC CV*
2352 S_deb_curcv(pTHX_ const I32 ix)
2353 {
2354     dVAR;
2355     const PERL_CONTEXT * const cx = &cxstack[ix];
2356     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2357         return cx->blk_sub.cv;
2358     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2359         return cx->blk_eval.cv;
2360     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2361         return PL_main_cv;
2362     else if (ix <= 0)
2363         return NULL;
2364     else
2365         return deb_curcv(ix - 1);
2366 }
2367
2368 void
2369 Perl_watch(pTHX_ char **addr)
2370 {
2371     dVAR;
2372
2373     PERL_ARGS_ASSERT_WATCH;
2374
2375     PL_watchaddr = addr;
2376     PL_watchok = *addr;
2377     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2378         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2379 }
2380
2381 STATIC void
2382 S_debprof(pTHX_ const OP *o)
2383 {
2384     dVAR;
2385
2386     PERL_ARGS_ASSERT_DEBPROF;
2387
2388     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2389         return;
2390     if (!PL_profiledata)
2391         Newxz(PL_profiledata, MAXO, U32);
2392     ++PL_profiledata[o->op_type];
2393 }
2394
2395 void
2396 Perl_debprofdump(pTHX)
2397 {
2398     dVAR;
2399     unsigned i;
2400     if (!PL_profiledata)
2401         return;
2402     for (i = 0; i < MAXO; i++) {
2403         if (PL_profiledata[i])
2404             PerlIO_printf(Perl_debug_log,
2405                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2406                                        PL_op_name[i]);
2407     }
2408 }
2409
2410 #ifdef PERL_MAD
2411 /*
2412  *    XML variants of most of the above routines
2413  */
2414
2415 STATIC void
2416 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2417 {
2418     va_list args;
2419
2420     PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2421
2422     PerlIO_printf(file, "\n    ");
2423     va_start(args, pat);
2424     xmldump_vindent(level, file, pat, &args);
2425     va_end(args);
2426 }
2427
2428
2429 void
2430 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2431 {
2432     va_list args;
2433     PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2434     va_start(args, pat);
2435     xmldump_vindent(level, file, pat, &args);
2436     va_end(args);
2437 }
2438
2439 void
2440 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2441 {
2442     PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2443
2444     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2445     PerlIO_vprintf(file, pat, *args);
2446 }
2447
2448 void
2449 Perl_xmldump_all(pTHX)
2450 {
2451     xmldump_all_perl(FALSE);
2452 }
2453
2454 void
2455 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2456 {
2457     PerlIO_setlinebuf(PL_xmlfp);
2458     if (PL_main_root)
2459         op_xmldump(PL_main_root);
2460     /* someday we might call this, when it outputs XML: */
2461     /* xmldump_packsubs_perl(PL_defstash, justperl); */
2462     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2463         PerlIO_close(PL_xmlfp);
2464     PL_xmlfp = 0;
2465 }
2466
2467 void
2468 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2469 {
2470     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2471     xmldump_packsubs_perl(stash, FALSE);
2472 }
2473
2474 void
2475 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2476 {
2477     I32 i;
2478     HE  *entry;
2479
2480     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2481
2482     if (!HvARRAY(stash))
2483         return;
2484     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2485         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2486             GV *gv = MUTABLE_GV(HeVAL(entry));
2487             HV *hv;
2488             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2489                 continue;
2490             if (GvCVu(gv))
2491                 xmldump_sub_perl(gv, justperl);
2492             if (GvFORM(gv))
2493                 xmldump_form(gv);
2494             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2495                 && (hv = GvHV(gv)) && hv != PL_defstash)
2496                 xmldump_packsubs_perl(hv, justperl);    /* nested package */
2497         }
2498     }
2499 }
2500
2501 void
2502 Perl_xmldump_sub(pTHX_ const GV *gv)
2503 {
2504     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2505     xmldump_sub_perl(gv, FALSE);
2506 }
2507
2508 void
2509 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2510 {
2511     SV * sv;
2512
2513     PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2514
2515     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2516         return;
2517
2518     sv = sv_newmortal();
2519     gv_fullname3(sv, gv, NULL);
2520     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2521     if (CvXSUB(GvCV(gv)))
2522         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2523             PTR2UV(CvXSUB(GvCV(gv))),
2524             (int)CvXSUBANY(GvCV(gv)).any_i32);
2525     else if (CvROOT(GvCV(gv)))
2526         op_xmldump(CvROOT(GvCV(gv)));
2527     else
2528         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2529 }
2530
2531 void
2532 Perl_xmldump_form(pTHX_ const GV *gv)
2533 {
2534     SV * const sv = sv_newmortal();
2535
2536     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2537
2538     gv_fullname3(sv, gv, NULL);
2539     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2540     if (CvROOT(GvFORM(gv)))
2541         op_xmldump(CvROOT(GvFORM(gv)));
2542     else
2543         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2544 }
2545
2546 void
2547 Perl_xmldump_eval(pTHX)
2548 {
2549     op_xmldump(PL_eval_root);
2550 }
2551
2552 char *
2553 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2554 {
2555     PERL_ARGS_ASSERT_SV_CATXMLSV;
2556     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2557 }
2558
2559 char *
2560 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2561 {
2562     PERL_ARGS_ASSERT_SV_CATXMLPV;
2563     return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2564 }
2565
2566 char *
2567 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2568 {
2569     unsigned int c;
2570     const char * const e = pv + len;
2571     const char * const start = pv;
2572     STRLEN dsvcur;
2573     STRLEN cl;
2574
2575     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2576
2577     sv_catpvs(dsv,"");
2578     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2579
2580   retry:
2581     while (pv < e) {
2582         if (utf8) {
2583             c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2584             if (cl == 0) {
2585                 SvCUR(dsv) = dsvcur;
2586                 pv = start;
2587                 utf8 = 0;
2588                 goto retry;
2589             }
2590         }
2591         else
2592             c = (*pv & 255);
2593
2594         switch (c) {
2595         case 0x00:
2596         case 0x01:
2597         case 0x02:
2598         case 0x03:
2599         case 0x04:
2600         case 0x05:
2601         case 0x06:
2602         case 0x07:
2603         case 0x08:
2604         case 0x0b:
2605         case 0x0c:
2606         case 0x0e:
2607         case 0x0f:
2608         case 0x10:
2609         case 0x11:
2610         case 0x12:
2611         case 0x13:
2612         case 0x14:
2613         case 0x15:
2614         case 0x16:
2615         case 0x17:
2616         case 0x18:
2617         case 0x19:
2618         case 0x1a:
2619         case 0x1b:
2620         case 0x1c:
2621         case 0x1d:
2622         case 0x1e:
2623         case 0x1f:
2624         case 0x7f:
2625         case 0x80:
2626         case 0x81:
2627         case 0x82:
2628         case 0x83:
2629         case 0x84:
2630         case 0x86:
2631         case 0x87:
2632         case 0x88:
2633         case 0x89:
2634         case 0x90:
2635         case 0x91:
2636         case 0x92:
2637         case 0x93:
2638         case 0x94:
2639         case 0x95:
2640         case 0x96:
2641         case 0x97:
2642         case 0x98:
2643         case 0x99:
2644         case 0x9a:
2645         case 0x9b:
2646         case 0x9c:
2647         case 0x9d:
2648         case 0x9e:
2649         case 0x9f:
2650             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2651             break;
2652         case '<':
2653             sv_catpvs(dsv, "&lt;");
2654             break;
2655         case '>':
2656             sv_catpvs(dsv, "&gt;");
2657             break;
2658         case '&':
2659             sv_catpvs(dsv, "&amp;");
2660             break;
2661         case '"':
2662             sv_catpvs(dsv, "&#34;");
2663             break;
2664         default:
2665             if (c < 0xD800) {
2666                 if (c < 32 || c > 127) {
2667                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2668                 }
2669                 else {
2670                     const char string = (char) c;
2671                     sv_catpvn(dsv, &string, 1);
2672                 }
2673                 break;
2674             }
2675             if ((c >= 0xD800 && c <= 0xDB7F) ||
2676                 (c >= 0xDC00 && c <= 0xDFFF) ||
2677                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2678                  c > 0x10ffff)
2679                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2680             else
2681                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2682         }
2683
2684         if (utf8)
2685             pv += UTF8SKIP(pv);
2686         else
2687             pv++;
2688     }
2689
2690     return SvPVX(dsv);
2691 }
2692
2693 char *
2694 Perl_sv_xmlpeek(pTHX_ SV *sv)
2695 {
2696     SV * const t = sv_newmortal();
2697     STRLEN n_a;
2698     int unref = 0;
2699
2700     PERL_ARGS_ASSERT_SV_XMLPEEK;
2701
2702     sv_utf8_upgrade(t);
2703     sv_setpvs(t, "");
2704     /* retry: */
2705     if (!sv) {
2706         sv_catpv(t, "VOID=\"\"");
2707         goto finish;
2708     }
2709     else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
2710         sv_catpv(t, "WILD=\"\"");
2711         goto finish;
2712     }
2713     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2714         if (sv == &PL_sv_undef) {
2715             sv_catpv(t, "SV_UNDEF=\"1\"");
2716             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2717                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2718                 SvREADONLY(sv))
2719                 goto finish;
2720         }
2721         else if (sv == &PL_sv_no) {
2722             sv_catpv(t, "SV_NO=\"1\"");
2723             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2724                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2725                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2726                                   SVp_POK|SVp_NOK)) &&
2727                 SvCUR(sv) == 0 &&
2728                 SvNVX(sv) == 0.0)
2729                 goto finish;
2730         }
2731         else if (sv == &PL_sv_yes) {
2732             sv_catpv(t, "SV_YES=\"1\"");
2733             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2734                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2735                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2736                                   SVp_POK|SVp_NOK)) &&
2737                 SvCUR(sv) == 1 &&
2738                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2739                 SvNVX(sv) == 1.0)
2740                 goto finish;
2741         }
2742         else {
2743             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2744             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2745                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2746                 SvREADONLY(sv))
2747                 goto finish;
2748         }
2749         sv_catpv(t, " XXX=\"\" ");
2750     }
2751     else if (SvREFCNT(sv) == 0) {
2752         sv_catpv(t, " refcnt=\"0\"");
2753         unref++;
2754     }
2755     else if (DEBUG_R_TEST_) {
2756         int is_tmp = 0;
2757         I32 ix;
2758         /* is this SV on the tmps stack? */
2759         for (ix=PL_tmps_ix; ix>=0; ix--) {
2760             if (PL_tmps_stack[ix] == sv) {
2761                 is_tmp = 1;
2762                 break;
2763             }
2764         }
2765         if (SvREFCNT(sv) > 1)
2766             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2767                     is_tmp ? "T" : "");
2768         else if (is_tmp)
2769             sv_catpv(t, " DRT=\"<T>\"");
2770     }
2771
2772     if (SvROK(sv)) {
2773         sv_catpv(t, " ROK=\"\"");
2774     }
2775     switch (SvTYPE(sv)) {
2776     default:
2777         sv_catpv(t, " FREED=\"1\"");
2778         goto finish;
2779
2780     case SVt_NULL:
2781         sv_catpv(t, " UNDEF=\"1\"");
2782         goto finish;
2783     case SVt_IV:
2784         sv_catpv(t, " IV=\"");
2785         break;
2786     case SVt_NV:
2787         sv_catpv(t, " NV=\"");
2788         break;
2789     case SVt_PV:
2790         sv_catpv(t, " PV=\"");
2791         break;
2792     case SVt_PVIV:
2793         sv_catpv(t, " PVIV=\"");
2794         break;
2795     case SVt_PVNV:
2796         sv_catpv(t, " PVNV=\"");
2797         break;
2798     case SVt_PVMG:
2799         sv_catpv(t, " PVMG=\"");
2800         break;
2801     case SVt_PVLV:
2802         sv_catpv(t, " PVLV=\"");
2803         break;
2804     case SVt_PVAV:
2805         sv_catpv(t, " AV=\"");
2806         break;
2807     case SVt_PVHV:
2808         sv_catpv(t, " HV=\"");
2809         break;
2810     case SVt_PVCV:
2811         if (CvGV(sv))
2812             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2813         else
2814             sv_catpv(t, " CV=\"()\"");
2815         goto finish;
2816     case SVt_PVGV:
2817         sv_catpv(t, " GV=\"");
2818         break;
2819     case SVt_INVLIST:
2820         sv_catpv(t, " DUMMY=\"");
2821         break;
2822     case SVt_REGEXP:
2823         sv_catpv(t, " REGEXP=\"");
2824         break;
2825     case SVt_PVFM:
2826         sv_catpv(t, " FM=\"");
2827         break;
2828     case SVt_PVIO:
2829         sv_catpv(t, " IO=\"");
2830         break;
2831     }
2832
2833     if (SvPOKp(sv)) {
2834         if (SvPVX(sv)) {
2835             sv_catxmlsv(t, sv);
2836         }
2837     }
2838     else if (SvNOKp(sv)) {
2839         STORE_NUMERIC_LOCAL_SET_STANDARD();
2840         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2841         RESTORE_NUMERIC_LOCAL();
2842     }
2843     else if (SvIOKp(sv)) {
2844         if (SvIsUV(sv))
2845             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2846         else
2847             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2848     }
2849     else
2850         sv_catpv(t, "");
2851     sv_catpv(t, "\"");
2852
2853   finish:
2854     while (unref--)
2855         sv_catpv(t, ")");
2856     return SvPV(t, n_a);
2857 }
2858
2859 void
2860 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2861 {
2862     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2863
2864     if (!pm) {
2865         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2866         return;
2867     }
2868     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2869     level++;
2870     if (PM_GETRE(pm)) {
2871         REGEXP *const r = PM_GETRE(pm);
2872         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2873         sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2874         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2875              SvPVX(tmpsv));
2876         SvREFCNT_dec_NN(tmpsv);
2877         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2878              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2879     }
2880     else
2881         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2882     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2883         SV * const tmpsv = pm_description(pm);
2884         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2885         SvREFCNT_dec_NN(tmpsv);
2886     }
2887
2888     level--;
2889     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2890         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2891         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2892         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2893         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2894         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2895     }
2896     else
2897         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2898 }
2899
2900 void
2901 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2902 {
2903     do_pmop_xmldump(0, PL_xmlfp, pm);
2904 }
2905
2906 void
2907 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2908 {
2909     UV      seq;
2910     int     contents = 0;
2911     const OPCODE optype = o->op_type;
2912
2913     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2914
2915     if (!o)
2916         return;
2917     seq = sequence_num(o);
2918     Perl_xmldump_indent(aTHX_ level, file,
2919         "<op_%s seq=\"%"UVuf" -> ",
2920              OP_NAME(o),
2921                       seq);
2922     level++;
2923     if (o->op_next)
2924         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2925                       sequence_num(o->op_next));
2926     else
2927         PerlIO_printf(file, "DONE\"");
2928
2929     if (o->op_targ) {
2930         if (optype == OP_NULL)
2931         {
2932             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2933             if (o->op_targ == OP_NEXTSTATE)
2934             {
2935                 if (CopLINE(cCOPo))
2936                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2937                                      (UV)CopLINE(cCOPo));
2938                 if (CopSTASHPV(cCOPo))
2939                     PerlIO_printf(file, " package=\"%s\"",
2940                                      CopSTASHPV(cCOPo));
2941                 if (CopLABEL(cCOPo))
2942                     PerlIO_printf(file, " label=\"%s\"",
2943                                      CopLABEL(cCOPo));
2944             }
2945         }
2946         else
2947             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2948     }
2949 #ifdef DUMPADDR
2950     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2951 #endif
2952
2953     DUMP_OP_FLAGS(o,1,0,file);
2954     DUMP_OP_PRIVATE(o,1,0,file);
2955
2956     switch (optype) {
2957     case OP_AELEMFAST:
2958         if (o->op_flags & OPf_SPECIAL) {
2959             break;
2960         }
2961     case OP_GVSV:
2962     case OP_GV:
2963 #ifdef USE_ITHREADS
2964         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2965 #else
2966         if (cSVOPo->op_sv) {
2967             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2968             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2969             char *s;
2970             STRLEN len;
2971             ENTER;
2972             SAVEFREESV(tmpsv1);
2973             SAVEFREESV(tmpsv2);
2974             gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2975             s = SvPV(tmpsv1,len);
2976             sv_catxmlpvn(tmpsv2, s, len, 1);
2977             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2978             LEAVE;
2979         }
2980         else
2981             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2982 #endif
2983         break;
2984     case OP_CONST:
2985     case OP_HINTSEVAL:
2986     case OP_METHOD_NAMED:
2987 #ifndef USE_ITHREADS
2988         /* with ITHREADS, consts are stored in the pad, and the right pad
2989          * may not be active here, so skip */
2990         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2991 #endif
2992         break;
2993     case OP_ANONCODE:
2994         if (!contents) {
2995             contents = 1;
2996             PerlIO_printf(file, ">\n");
2997         }
2998         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2999         break;
3000     case OP_NEXTSTATE:
3001     case OP_DBSTATE:
3002         if (CopLINE(cCOPo))
3003             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3004                              (UV)CopLINE(cCOPo));
3005         if (CopSTASHPV(cCOPo))
3006             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3007                              CopSTASHPV(cCOPo));
3008         if (CopLABEL(cCOPo))
3009             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3010                              CopLABEL(cCOPo));
3011         break;
3012     case OP_ENTERLOOP:
3013         S_xmldump_attr(aTHX_ level, file, "redo=\"");
3014         if (cLOOPo->op_redoop)
3015             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3016         else
3017             PerlIO_printf(file, "DONE\"");
3018         S_xmldump_attr(aTHX_ level, file, "next=\"");
3019         if (cLOOPo->op_nextop)
3020             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3021         else
3022             PerlIO_printf(file, "DONE\"");
3023         S_xmldump_attr(aTHX_ level, file, "last=\"");
3024         if (cLOOPo->op_lastop)
3025             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3026         else
3027             PerlIO_printf(file, "DONE\"");
3028         break;
3029     case OP_COND_EXPR:
3030     case OP_RANGE:
3031     case OP_MAPWHILE:
3032     case OP_GREPWHILE:
3033     case OP_OR:
3034     case OP_AND:
3035         S_xmldump_attr(aTHX_ level, file, "other=\"");
3036         if (cLOGOPo->op_other)
3037             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3038         else
3039             PerlIO_printf(file, "DONE\"");
3040         break;
3041     case OP_LEAVE:
3042     case OP_LEAVEEVAL:
3043     case OP_LEAVESUB:
3044     case OP_LEAVESUBLV:
3045     case OP_LEAVEWRITE:
3046     case OP_SCOPE:
3047         if (o->op_private & OPpREFCOUNTED)
3048             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3049         break;
3050     default:
3051         break;
3052     }
3053
3054     if (PL_madskills && o->op_madprop) {
3055         char prevkey = '\0';
3056         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3057         const MADPROP* mp = o->op_madprop;
3058
3059         if (!contents) {
3060             contents = 1;
3061             PerlIO_printf(file, ">\n");
3062         }
3063         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3064         level++;
3065         while (mp) {
3066             char tmp = mp->mad_key;
3067             sv_setpvs(tmpsv,"\"");
3068             if (tmp)
3069                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3070             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3071                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3072             else
3073                 prevkey = tmp;
3074             sv_catpv(tmpsv, "\"");
3075             switch (mp->mad_type) {
3076             case MAD_NULL:
3077                 sv_catpv(tmpsv, "NULL");
3078                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3079                 break;
3080             case MAD_PV:
3081                 sv_catpv(tmpsv, " val=\"");
3082                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3083                 sv_catpv(tmpsv, "\"");
3084                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3085                 break;
3086             case MAD_SV:
3087                 sv_catpv(tmpsv, " val=\"");
3088                 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3089                 sv_catpv(tmpsv, "\"");
3090                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3091                 break;
3092             case MAD_OP:
3093                 if ((OP*)mp->mad_val) {
3094                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3095                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3096                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3097                 }
3098                 break;
3099             default:
3100                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3101                 break;
3102             }
3103             mp = mp->mad_next;
3104         }
3105         level--;
3106         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3107
3108         SvREFCNT_dec_NN(tmpsv);
3109     }
3110
3111     switch (optype) {
3112     case OP_PUSHRE:
3113     case OP_MATCH:
3114     case OP_QR:
3115     case OP_SUBST:
3116         if (!contents) {
3117             contents = 1;
3118             PerlIO_printf(file, ">\n");
3119         }
3120         do_pmop_xmldump(level, file, cPMOPo);
3121         break;
3122     default:
3123         break;
3124     }
3125
3126     if (o->op_flags & OPf_KIDS) {
3127         OP *kid;
3128         if (!contents) {
3129             contents = 1;
3130             PerlIO_printf(file, ">\n");
3131         }
3132         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3133             do_op_xmldump(level, file, kid);
3134     }
3135
3136     if (contents)
3137         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3138     else
3139         PerlIO_printf(file, " />\n");
3140 }
3141
3142 void
3143 Perl_op_xmldump(pTHX_ const OP *o)
3144 {
3145     PERL_ARGS_ASSERT_OP_XMLDUMP;
3146
3147     do_op_xmldump(0, PL_xmlfp, o);
3148 }
3149 #endif
3150
3151 /*
3152  * Local variables:
3153  * c-indentation-style: bsd
3154  * c-basic-offset: 4
3155  * indent-tabs-mode: nil
3156  * End:
3157  *
3158  * ex: set ts=8 sts=4 sw=4 et:
3159  */