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