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