dump.c

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