dump.c

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