dump.c

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