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