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_buf((U8*)pv, (U8*) end, &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 };
 738
 739 const struct flag_to_name op_sort_names[] = {
 740     {OPpSORT_NUMERIC, ",NUMERIC"},
 741     {OPpSORT_INTEGER, ",INTEGER"},
 742     {OPpSORT_REVERSE, ",REVERSE"},
 743     {OPpSORT_INPLACE, ",INPLACE"},
 744     {OPpSORT_DESCEND, ",DESCEND"},
 745     {OPpSORT_QSORT, ",QSORT"},
 746     {OPpSORT_STABLE, ",STABLE"}
 747 };
 748
 749 const struct flag_to_name op_open_names[] = {
 750     {OPpOPEN_IN_RAW, ",IN_RAW"},
 751     {OPpOPEN_IN_CRLF, ",IN_CRLF"},
 752     {OPpOPEN_OUT_RAW, ",OUT_RAW"},
 753     {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
 754 };
 755
 756 const struct flag_to_name op_exit_names[] = {
 757     {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
 758     {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
 759 };
 760
 761 #define OP_PRIVATE_ONCE(op, flag, name) \
 762     const struct flag_to_name CAT2(op, _names)[] = {    \
 763         {(flag), (name)} \
 764     }
 765
 766 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
 767 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
 768 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
 769 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
 770 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
 771 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
 772 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
 773 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
 774 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
 775 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
 776 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
 777 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
 778
 779 struct op_private_by_op {
 780     U16 op_type;
 781     U16 len;
 782     const struct flag_to_name *start;
 783 };
 784
 785 const struct op_private_by_op op_private_names[] = {
 786     {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 787     {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 788     {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 789     {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 790     {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
 791     {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
 792     {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
 793     {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
 794     {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
 795     {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
 796     {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
 797     {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
 798     {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
 799     {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
 800     {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
 801     {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
 802     {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
 803     {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
 804     {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
 805     {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
 806     {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
 807 };
 808
 809 static bool
 810 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
 811     const struct op_private_by_op *start = op_private_names;
 812     const struct op_private_by_op *const end
 813         = op_private_names + C_ARRAY_LENGTH(op_private_names);
 814
 815     /* This is a linear search, but no worse than the code that it replaced.
 816        It's debugging code - size is more important than speed.  */
 817     do {
 818         if (optype == start->op_type) {
 819             S_append_flags(aTHX_ tmpsv, op_private, start->start,
 820                            start->start + start->len);
 821             return TRUE;
 822         }
 823     } while (++start < end);
 824     return FALSE;
 825 }
 826
 827 void
 828 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 829 {
 830     dVAR;
 831     UV      seq;
 832     const OPCODE optype = o->op_type;
 833
 834     PERL_ARGS_ASSERT_DO_OP_DUMP;
 835
 836     Perl_dump_indent(aTHX_ level, file, "{\n");
 837     level++;
 838     seq = sequence_num(o);
 839     if (seq)
 840         PerlIO_printf(file, "%-4"UVuf, seq);
 841     else
 842         PerlIO_printf(file, "????");
 843     PerlIO_printf(file,
 844                   "%*sTYPE = %s  ===> ",
 845                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
 846     if (o->op_next)
 847         PerlIO_printf(file,
 848                         o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
 849                                 sequence_num(o->op_next));
 850     else
 851         PerlIO_printf(file, "NULL\n");
 852     if (o->op_targ) {
 853         if (optype == OP_NULL) {
 854             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
 855             if (o->op_targ == OP_NEXTSTATE) {
 856                 if (CopLINE(cCOPo))
 857                     Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
 858                                      (UV)CopLINE(cCOPo));
 859                 if (CopSTASHPV(cCOPo))
 860                     Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
 861                                      CopSTASHPV(cCOPo));
 862                 if (CopLABEL(cCOPo))
 863                     Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
 864                                      CopLABEL(cCOPo));
 865             }
 866         }
 867         else
 868             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
 869     }
 870 #ifdef DUMPADDR
 871     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
 872 #endif
 873     if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
 874         SV * const tmpsv = newSVpvs("");
 875         switch (o->op_flags & OPf_WANT) {
 876         case OPf_WANT_VOID:
 877             sv_catpv(tmpsv, ",VOID");
 878             break;
 879         case OPf_WANT_SCALAR:
 880             sv_catpv(tmpsv, ",SCALAR");
 881             break;
 882         case OPf_WANT_LIST:
 883             sv_catpv(tmpsv, ",LIST");
 884             break;
 885         default:
 886             sv_catpv(tmpsv, ",UNKNOWN");
 887             break;
 888         }
 889         append_flags(tmpsv, o->op_flags, op_flags_names);
 890         if (o->op_latefree)
 891             sv_catpv(tmpsv, ",LATEFREE");
 892         if (o->op_latefreed)
 893             sv_catpv(tmpsv, ",LATEFREED");
 894         if (o->op_attached)
 895             sv_catpv(tmpsv, ",ATTACHED");
 896         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 897         SvREFCNT_dec(tmpsv);
 898     }
 899     if (o->op_private) {
 900         SV * const tmpsv = newSVpvs("");
 901         if (PL_opargs[optype] & OA_TARGLEX) {
 902             if (o->op_private & OPpTARGET_MY)
 903                 sv_catpv(tmpsv, ",TARGET_MY");
 904         }
 905         else if (optype == OP_ENTERSUB ||
 906             optype == OP_RV2SV ||
 907             optype == OP_GVSV ||
 908             optype == OP_RV2AV ||
 909             optype == OP_RV2HV ||
 910             optype == OP_RV2GV ||
 911             optype == OP_AELEM ||
 912             optype == OP_HELEM )
 913         {
 914             if (optype == OP_ENTERSUB) {
 915                 append_flags(tmpsv, o->op_private, op_entersub_names);
 916             }
 917             else {
 918                 switch (o->op_private & OPpDEREF) {
 919                 case OPpDEREF_SV:
 920                     sv_catpv(tmpsv, ",SV");
 921                     break;
 922                 case OPpDEREF_AV:
 923                     sv_catpv(tmpsv, ",AV");
 924                     break;
 925                 case OPpDEREF_HV:
 926                     sv_catpv(tmpsv, ",HV");
 927                     break;
 928                 }
 929                 if (o->op_private & OPpMAYBE_LVSUB)
 930                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
 931             }
 932
 933             if (optype == OP_AELEM || optype == OP_HELEM) {
 934                 if (o->op_private & OPpLVAL_DEFER)
 935                     sv_catpv(tmpsv, ",LVAL_DEFER");
 936             }
 937             else {
 938                 if (o->op_private & HINT_STRICT_REFS)
 939                     sv_catpv(tmpsv, ",STRICT_REFS");
 940                 if (o->op_private & OPpOUR_INTRO)
 941                     sv_catpv(tmpsv, ",OUR_INTRO");
 942             }
 943         }
 944         else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
 945         }
 946         else if (PL_check[optype] != Perl_ck_ftst) {
 947             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
 948                 sv_catpv(tmpsv, ",FT_ACCESS");
 949             if (o->op_private & OPpFT_STACKED)
 950                 sv_catpv(tmpsv, ",FT_STACKED");
 951         }
 952         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
 953             sv_catpv(tmpsv, ",INTRO");
 954         if (SvCUR(tmpsv))
 955             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
 956         SvREFCNT_dec(tmpsv);
 957     }
 958
 959 #ifdef PERL_MAD
 960     if (PL_madskills && o->op_madprop) {
 961         SV * const tmpsv = newSVpvs("");
 962         MADPROP* mp = o->op_madprop;
 963         Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
 964         level++;
 965         while (mp) {
 966             const char tmp = mp->mad_key;
 967             sv_setpvs(tmpsv,"'");
 968             if (tmp)
 969                 sv_catpvn(tmpsv, &tmp, 1);
 970             sv_catpv(tmpsv, "'=");
 971             switch (mp->mad_type) {
 972             case MAD_NULL:
 973                 sv_catpv(tmpsv, "NULL");
 974                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
 975                 break;
 976             case MAD_PV:
 977                 sv_catpv(tmpsv, "<");
 978                 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
 979                 sv_catpv(tmpsv, ">");
 980                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
 981                 break;
 982             case MAD_OP:
 983                 if ((OP*)mp->mad_val) {
 984                     Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
 985                     do_op_dump(level, file, (OP*)mp->mad_val);
 986                 }
 987                 break;
 988             default:
 989                 sv_catpv(tmpsv, "(UNK)");
 990                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
 991                 break;
 992             }
 993             mp = mp->mad_next;
 994         }
 995         level--;
 996         Perl_dump_indent(aTHX_ level, file, "}\n");
 997
 998         SvREFCNT_dec(tmpsv);
 999     }
1000 #endif
1001
1002     switch (optype) {
1003     case OP_AELEMFAST:
1004     case OP_GVSV:
1005     case OP_GV:
1006 #ifdef USE_ITHREADS
1007         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1008 #else
1009         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1010             if (cSVOPo->op_sv) {
1011                 SV * const tmpsv = newSV(0);
1012                 ENTER;
1013                 SAVEFREESV(tmpsv);
1014 #ifdef PERL_MAD
1015                 /* FIXME - is this making unwarranted assumptions about the
1016                    UTF-8 cleanliness of the dump file handle?  */
1017                 SvUTF8_on(tmpsv);
1018 #endif
1019                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1020                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1021                                  SvPV_nolen_const(tmpsv));
1022                 LEAVE;
1023             }
1024             else
1025                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1026         }
1027 #endif
1028         break;
1029     case OP_CONST:
1030     case OP_HINTSEVAL:
1031     case OP_METHOD_NAMED:
1032 #ifndef USE_ITHREADS
1033         /* with ITHREADS, consts are stored in the pad, and the right pad
1034          * may not be active here, so skip */
1035         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1036 #endif
1037         break;
1038     case OP_NEXTSTATE:
1039     case OP_DBSTATE:
1040         if (CopLINE(cCOPo))
1041             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1042                              (UV)CopLINE(cCOPo));
1043         if (CopSTASHPV(cCOPo))
1044             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1045                              CopSTASHPV(cCOPo));
1046         if (CopLABEL(cCOPo))
1047             Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1048                              CopLABEL(cCOPo));
1049         break;
1050     case OP_ENTERLOOP:
1051         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1052         if (cLOOPo->op_redoop)
1053             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1054         else
1055             PerlIO_printf(file, "DONE\n");
1056         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1057         if (cLOOPo->op_nextop)
1058             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1059         else
1060             PerlIO_printf(file, "DONE\n");
1061         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1062         if (cLOOPo->op_lastop)
1063             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1064         else
1065             PerlIO_printf(file, "DONE\n");
1066         break;
1067     case OP_COND_EXPR:
1068     case OP_RANGE:
1069     case OP_MAPWHILE:
1070     case OP_GREPWHILE:
1071     case OP_OR:
1072     case OP_AND:
1073         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1074         if (cLOGOPo->op_other)
1075             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1076         else
1077             PerlIO_printf(file, "DONE\n");
1078         break;
1079     case OP_PUSHRE:
1080     case OP_MATCH:
1081     case OP_QR:
1082     case OP_SUBST:
1083         do_pmop_dump(level, file, cPMOPo);
1084         break;
1085     case OP_LEAVE:
1086     case OP_LEAVEEVAL:
1087     case OP_LEAVESUB:
1088     case OP_LEAVESUBLV:
1089     case OP_LEAVEWRITE:
1090     case OP_SCOPE:
1091         if (o->op_private & OPpREFCOUNTED)
1092             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1093         break;
1094     default:
1095         break;
1096     }
1097     if (o->op_flags & OPf_KIDS) {
1098         OP *kid;
1099         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1100             do_op_dump(level, file, kid);
1101     }
1102     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1103 }
1104
1105 void
1106 Perl_op_dump(pTHX_ const OP *o)
1107 {
1108     PERL_ARGS_ASSERT_OP_DUMP;
1109     do_op_dump(0, Perl_debug_log, o);
1110 }
1111
1112 void
1113 Perl_gv_dump(pTHX_ GV *gv)
1114 {
1115     SV *sv;
1116
1117     PERL_ARGS_ASSERT_GV_DUMP;
1118
1119     if (!gv) {
1120         PerlIO_printf(Perl_debug_log, "{}\n");
1121         return;
1122     }
1123     sv = sv_newmortal();
1124     PerlIO_printf(Perl_debug_log, "{\n");
1125     gv_fullname3(sv, gv, NULL);
1126     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1127     if (gv != GvEGV(gv)) {
1128         gv_efullname3(sv, GvEGV(gv), NULL);
1129         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1130     }
1131     PerlIO_putc(Perl_debug_log, '\n');
1132     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1133 }
1134
1135
1136 /* map magic types to the symbolic names
1137  * (with the PERL_MAGIC_ prefixed stripped)
1138  */
1139
1140 static const struct { const char type; const char *name; } magic_names[] = {
1141 #include "mg_names.c"
1142         /* this null string terminates the list */
1143         { 0,                         NULL },
1144 };
1145
1146 void
1147 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1148 {
1149     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1150
1151     for (; mg; mg = mg->mg_moremagic) {
1152         Perl_dump_indent(aTHX_ level, file,
1153                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1154         if (mg->mg_virtual) {
1155             const MGVTBL * const v = mg->mg_virtual;
1156             if (v >= PL_magic_vtables
1157                 && v < PL_magic_vtables + magic_vtable_max) {
1158                 const U32 i = v - PL_magic_vtables;
1159                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1160             }
1161             else
1162                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1163         }
1164         else
1165             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1166
1167         if (mg->mg_private)
1168             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1169
1170         {
1171             int n;
1172             const char *name = NULL;
1173             for (n = 0; magic_names[n].name; n++) {
1174                 if (mg->mg_type == magic_names[n].type) {
1175                     name = magic_names[n].name;
1176                     break;
1177                 }
1178             }
1179             if (name)
1180                 Perl_dump_indent(aTHX_ level, file,
1181                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1182             else
1183                 Perl_dump_indent(aTHX_ level, file,
1184                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1185         }
1186
1187         if (mg->mg_flags) {
1188             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1189             if (mg->mg_type == PERL_MAGIC_envelem &&
1190                 mg->mg_flags & MGf_TAINTEDDIR)
1191                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1192             if (mg->mg_type == PERL_MAGIC_regex_global &&
1193                 mg->mg_flags & MGf_MINMATCH)
1194                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1195             if (mg->mg_flags & MGf_REFCOUNTED)
1196                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1197             if (mg->mg_flags & MGf_GSKIP)
1198                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1199             if (mg->mg_flags & MGf_COPY)
1200                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1201             if (mg->mg_flags & MGf_DUP)
1202                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1203             if (mg->mg_flags & MGf_LOCAL)
1204                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1205         }
1206         if (mg->mg_obj) {
1207             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1208                 PTR2UV(mg->mg_obj));
1209             if (mg->mg_type == PERL_MAGIC_qr) {
1210                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1211                 SV * const dsv = sv_newmortal();
1212                 const char * const s
1213                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1214                     60, NULL, NULL,
1215                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1216                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1217                 );
1218                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1219                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1220                         (IV)RX_REFCNT(re));
1221             }
1222             if (mg->mg_flags & MGf_REFCOUNTED)
1223                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1224         }
1225         if (mg->mg_len)
1226             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1227         if (mg->mg_ptr) {
1228             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1229             if (mg->mg_len >= 0) {
1230                 if (mg->mg_type != PERL_MAGIC_utf8) {
1231                     SV * const sv = newSVpvs("");
1232                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1233                     SvREFCNT_dec(sv);
1234                 }
1235             }
1236             else if (mg->mg_len == HEf_SVKEY) {
1237                 PerlIO_puts(file, " => HEf_SVKEY\n");
1238                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1239                            maxnest, dumpops, pvlim); /* MG is already +1 */
1240                 continue;
1241             }
1242             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1243             else
1244                 PerlIO_puts(
1245                   file,
1246                  " ???? - " __FILE__
1247                  " does not know how to handle this MG_LEN"
1248                 );
1249             PerlIO_putc(file, '\n');
1250         }
1251         if (mg->mg_type == PERL_MAGIC_utf8) {
1252             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1253             if (cache) {
1254                 IV i;
1255                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1256                     Perl_dump_indent(aTHX_ level, file,
1257                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1258                                      i,
1259                                      (UV)cache[i * 2],
1260                                      (UV)cache[i * 2 + 1]);
1261             }
1262         }
1263     }
1264 }
1265
1266 void
1267 Perl_magic_dump(pTHX_ const MAGIC *mg)
1268 {
1269     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1270 }
1271
1272 void
1273 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1274 {
1275     const char *hvname;
1276
1277     PERL_ARGS_ASSERT_DO_HV_DUMP;
1278
1279     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1280     if (sv && (hvname = HvNAME_get(sv)))
1281     {
1282         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1283            name which quite legally could contain insane things like tabs, newlines, nulls or
1284            other scary crap - this should produce sane results - except maybe for unicode package
1285            names - but we will wait for someone to file a bug on that - demerphq */
1286         SV * const tmpsv = newSVpvs("");
1287         PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1288     }
1289     else
1290         PerlIO_putc(file, '\n');
1291 }
1292
1293 void
1294 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1295 {
1296     PERL_ARGS_ASSERT_DO_GV_DUMP;
1297
1298     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1299     if (sv && GvNAME(sv))
1300         PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1301     else
1302         PerlIO_putc(file, '\n');
1303 }
1304
1305 void
1306 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1307 {
1308     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1309
1310     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1311     if (sv && GvNAME(sv)) {
1312         const char *hvname;
1313         PerlIO_printf(file, "\t\"");
1314         if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1315             PerlIO_printf(file, "%s\" :: \"", hvname);
1316         PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1317     }
1318     else
1319         PerlIO_putc(file, '\n');
1320 }
1321
1322 const struct flag_to_name first_sv_flags_names[] = {
1323     {SVs_TEMP, "TEMP,"},
1324     {SVs_OBJECT, "OBJECT,"},
1325     {SVs_GMG, "GMG,"},
1326     {SVs_SMG, "SMG,"},
1327     {SVs_RMG, "RMG,"},
1328     {SVf_IOK, "IOK,"},
1329     {SVf_NOK, "NOK,"},
1330     {SVf_POK, "POK,"}
1331 };
1332
1333 const struct flag_to_name second_sv_flags_names[] = {
1334     {SVf_OOK, "OOK,"},
1335     {SVf_FAKE, "FAKE,"},
1336     {SVf_READONLY, "READONLY,"},
1337     {SVf_BREAK, "BREAK,"},
1338     {SVf_AMAGIC, "OVERLOAD,"},
1339     {SVp_IOK, "pIOK,"},
1340     {SVp_NOK, "pNOK,"},
1341     {SVp_POK, "pPOK,"}
1342 };
1343
1344 const struct flag_to_name cv_flags_names[] = {
1345     {CVf_ANON, "ANON,"},
1346     {CVf_UNIQUE, "UNIQUE,"},
1347     {CVf_CLONE, "CLONE,"},
1348     {CVf_CLONED, "CLONED,"},
1349     {CVf_CONST, "CONST,"},
1350     {CVf_NODEBUG, "NODEBUG,"},
1351     {CVf_LVALUE, "LVALUE,"},
1352     {CVf_METHOD, "METHOD,"},
1353     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1354     {CVf_CVGV_RC, "CVGV_RC,"},
1355     {CVf_DYNFILE, "DYNFILE,"},
1356     {CVf_AUTOLOAD, "AUTOLOAD,"},
1357     {CVf_ISXSUB, "ISXSUB,"}
1358 };
1359
1360 const struct flag_to_name hv_flags_names[] = {
1361     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1362     {SVphv_LAZYDEL, "LAZYDEL,"},
1363     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1364     {SVphv_REHASH, "REHASH,"},
1365     {SVphv_CLONEABLE, "CLONEABLE,"}
1366 };
1367
1368 const struct flag_to_name gp_flags_names[] = {
1369     {GVf_INTRO, "INTRO,"},
1370     {GVf_MULTI, "MULTI,"},
1371     {GVf_ASSUMECV, "ASSUMECV,"},
1372     {GVf_IN_PAD, "IN_PAD,"}
1373 };
1374
1375 const struct flag_to_name gp_flags_imported_names[] = {
1376     {GVf_IMPORTED_SV, " SV"},
1377     {GVf_IMPORTED_AV, " AV"},
1378     {GVf_IMPORTED_HV, " HV"},
1379     {GVf_IMPORTED_CV, " CV"},
1380 };
1381
1382 const struct flag_to_name regexp_flags_names[] = {
1383     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1384     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1385     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1386     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1387     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1388     {RXf_ANCH_BOL,        "ANCH_BOL,"},
1389     {RXf_ANCH_MBOL,       "ANCH_MBOL,"},
1390     {RXf_ANCH_SBOL,       "ANCH_SBOL,"},
1391     {RXf_ANCH_GPOS,       "ANCH_GPOS,"},
1392     {RXf_GPOS_SEEN,       "GPOS_SEEN,"},
1393     {RXf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1394     {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1395     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1396     {RXf_CANY_SEEN,       "CANY_SEEN,"},
1397     {RXf_NOSCAN,          "NOSCAN,"},
1398     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1399     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1400     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1401     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1402     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1403     {RXf_SPLIT,           "SPLIT,"},
1404     {RXf_COPY_DONE,       "COPY_DONE,"},
1405     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1406     {RXf_TAINTED,         "TAINTED,"},
1407     {RXf_START_ONLY,      "START_ONLY,"},
1408     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1409     {RXf_WHITE,           "WHITE,"},
1410     {RXf_NULL,            "NULL,"},
1411 };
1412
1413 void
1414 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1415 {
1416     dVAR;
1417     SV *d;
1418     const char *s;
1419     U32 flags;
1420     U32 type;
1421
1422     PERL_ARGS_ASSERT_DO_SV_DUMP;
1423
1424     if (!sv) {
1425         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1426         return;
1427     }
1428
1429     flags = SvFLAGS(sv);
1430     type = SvTYPE(sv);
1431
1432     /* process general SV flags */
1433
1434     d = Perl_newSVpvf(aTHX_
1435                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1436                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1437                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1438                    (int)(PL_dumpindent*level), "");
1439
1440     if (!((flags & SVpad_NAME) == SVpad_NAME
1441           && (type == SVt_PVMG || type == SVt_PVNV))) {
1442         if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1443             sv_catpv(d, "PADSTALE,");
1444     }
1445     if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1446         if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1447             sv_catpv(d, "PADTMP,");
1448         if (flags & SVs_PADMY)  sv_catpv(d, "PADMY,");
1449     }
1450     append_flags(d, flags, first_sv_flags_names);
1451     if (flags & SVf_ROK)  {
1452                                 sv_catpv(d, "ROK,");
1453         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1454     }
1455     append_flags(d, flags, second_sv_flags_names);
1456     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1457         if (SvPCS_IMPORTED(sv))
1458                                 sv_catpv(d, "PCS_IMPORTED,");
1459         else
1460                                 sv_catpv(d, "SCREAM,");
1461     }
1462
1463     /* process type-specific SV flags */
1464
1465     switch (type) {
1466     case SVt_PVCV:
1467     case SVt_PVFM:
1468         append_flags(d, CvFLAGS(sv), cv_flags_names);
1469         break;
1470     case SVt_PVHV:
1471         append_flags(d, flags, hv_flags_names);
1472         break;
1473     case SVt_PVGV:
1474     case SVt_PVLV:
1475         if (isGV_with_GP(sv)) {
1476             append_flags(d, GvFLAGS(sv), gp_flags_names);
1477         }
1478         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1479             sv_catpv(d, "IMPORT");
1480             if (GvIMPORTED(sv) == GVf_IMPORTED)
1481                 sv_catpv(d, "ALL,");
1482             else {
1483                 sv_catpv(d, "(");
1484                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1485                 sv_catpv(d, " ),");
1486             }
1487         }
1488         /* FALL THROUGH */
1489     default:
1490     evaled_or_uv:
1491         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1492         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1493         break;
1494     case SVt_PVMG:
1495         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1496         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1497         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1498         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1499         /* FALL THROUGH */
1500     case SVt_PVNV:
1501         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1502         goto evaled_or_uv;
1503     case SVt_PVAV:
1504         break;
1505     }
1506     /* SVphv_SHAREKEYS is also 0x20000000 */
1507     if ((type != SVt_PVHV) && SvUTF8(sv))
1508         sv_catpv(d, "UTF8");
1509
1510     if (*(SvEND(d) - 1) == ',') {
1511         SvCUR_set(d, SvCUR(d) - 1);
1512         SvPVX(d)[SvCUR(d)] = '\0';
1513     }
1514     sv_catpv(d, ")");
1515     s = SvPVX_const(d);
1516
1517     /* dump initial SV details */
1518
1519 #ifdef DEBUG_LEAKING_SCALARS
1520     Perl_dump_indent(aTHX_ level, file,
1521         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1522         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1523         sv->sv_debug_line,
1524         sv->sv_debug_inpad ? "for" : "by",
1525         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1526         PTR2UV(sv->sv_debug_parent),
1527         sv->sv_debug_serial
1528     );
1529 #endif
1530     Perl_dump_indent(aTHX_ level, file, "SV = ");
1531
1532     /* Dump SV type */
1533
1534     if (type < SVt_LAST) {
1535         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1536
1537         if (type ==  SVt_NULL) {
1538             SvREFCNT_dec(d);
1539             return;
1540         }
1541     } else {
1542         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1543         SvREFCNT_dec(d);
1544         return;
1545     }
1546
1547     /* Dump general SV fields */
1548
1549     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1550          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1551          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1552         || (type == SVt_IV && !SvROK(sv))) {
1553         if (SvIsUV(sv)
1554 #ifdef PERL_OLD_COPY_ON_WRITE
1555                        || SvIsCOW(sv)
1556 #endif
1557                                      )
1558             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1559         else
1560             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1561 #ifdef PERL_OLD_COPY_ON_WRITE
1562         if (SvIsCOW_shared_hash(sv))
1563             PerlIO_printf(file, "  (HASH)");
1564         else if (SvIsCOW_normal(sv))
1565             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1566 #endif
1567         PerlIO_putc(file, '\n');
1568     }
1569
1570     if ((type == SVt_PVNV || type == SVt_PVMG)
1571         && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1572         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1573                          (UV) COP_SEQ_RANGE_LOW(sv));
1574         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1575                          (UV) COP_SEQ_RANGE_HIGH(sv));
1576     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1577                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1578                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1579                || type == SVt_NV) {
1580         STORE_NUMERIC_LOCAL_SET_STANDARD();
1581         /* %Vg doesn't work? --jhi */
1582 #ifdef USE_LONG_DOUBLE
1583         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1584 #else
1585         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1586 #endif
1587         RESTORE_NUMERIC_LOCAL();
1588     }
1589
1590     if (SvROK(sv)) {
1591         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1592         if (nest < maxnest)
1593             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1594     }
1595
1596     if (type < SVt_PV) {
1597         SvREFCNT_dec(d);
1598         return;
1599     }
1600
1601     if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1602         if (SvPVX_const(sv)) {
1603             STRLEN delta;
1604             if (SvOOK(sv)) {
1605                 SvOOK_offset(sv, delta);
1606                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1607                                  (UV) delta);
1608             } else {
1609                 delta = 0;
1610             }
1611             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1612             if (SvOOK(sv)) {
1613                 PerlIO_printf(file, "( %s . ) ",
1614                               pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1615                                          pvlim));
1616             }
1617             PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1618             if (SvUTF8(sv)) /* the 6?  \x{....} */
1619                 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1620             PerlIO_printf(file, "\n");
1621             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1622             Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
1623         }
1624         else
1625             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1626     }
1627
1628     if (type >= SVt_PVMG) {
1629         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1630             HV * const ost = SvOURSTASH(sv);
1631             if (ost)
1632                 do_hv_dump(level, file, "  OURSTASH", ost);
1633         } else {
1634             if (SvMAGIC(sv))
1635                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1636         }
1637         if (SvSTASH(sv))
1638             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1639
1640         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1641             Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
1642             Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1643             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1644         }
1645     }
1646
1647     /* Dump type-specific SV fields */
1648
1649     switch (type) {
1650     case SVt_PVAV:
1651         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1652         if (AvARRAY(sv) != AvALLOC(sv)) {
1653             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1654             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1655         }
1656         else
1657             PerlIO_putc(file, '\n');
1658         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1659         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1660         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1661         sv_setpvs(d, "");
1662         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1663         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1664         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1665                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1666         if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1667             int count;
1668             for (count = 0; count <=  av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1669                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1670
1671                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1672                 if (elt)
1673                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1674             }
1675         }
1676         break;
1677     case SVt_PVHV:
1678         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1679         if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1680             /* Show distribution of HEs in the ARRAY */
1681             int freq[200];
1682 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1683             int i;
1684             int max = 0;
1685             U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1686             NV theoret, sum = 0;
1687
1688             PerlIO_printf(file, "  (");
1689             Zero(freq, FREQ_MAX + 1, int);
1690             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1691                 HE* h;
1692                 int count = 0;
1693                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1694                     count++;
1695                 if (count > FREQ_MAX)
1696                     count = FREQ_MAX;
1697                 freq[count]++;
1698                 if (max < count)
1699                     max = count;
1700             }
1701             for (i = 0; i <= max; i++) {
1702                 if (freq[i]) {
1703                     PerlIO_printf(file, "%d%s:%d", i,
1704                                   (i == FREQ_MAX) ? "+" : "",
1705                                   freq[i]);
1706                     if (i != max)
1707                         PerlIO_printf(file, ", ");
1708                 }
1709             }
1710             PerlIO_putc(file, ')');
1711             /* The "quality" of a hash is defined as the total number of
1712                comparisons needed to access every element once, relative
1713                to the expected number needed for a random hash.
1714
1715                The total number of comparisons is equal to the sum of
1716                the squares of the number of entries in each bucket.
1717                For a random hash of n keys into k buckets, the expected
1718                value is
1719                                 n + n(n-1)/2k
1720             */
1721
1722             for (i = max; i > 0; i--) { /* Precision: count down. */
1723                 sum += freq[i] * i * i;
1724             }
1725             while ((keys = keys >> 1))
1726                 pow2 = pow2 << 1;
1727             theoret = HvUSEDKEYS(sv);
1728             theoret += theoret * (theoret-1)/pow2;
1729             PerlIO_putc(file, '\n');
1730             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1731         }
1732         PerlIO_putc(file, '\n');
1733         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1734         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1735         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1736         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1737         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1738         {
1739             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1740             if (mg && mg->mg_obj) {
1741                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1742             }
1743         }
1744         {
1745             const char * const hvname = HvNAME_get(sv);
1746             if (hvname)
1747                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1748         }
1749         if (SvOOK(sv)) {
1750             AV * const backrefs
1751                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1752             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1753             if (HvAUX(sv)->xhv_name_count)
1754                 Perl_dump_indent(aTHX_
1755                  level, file, "  NAMECOUNT = %"IVdf"\n",
1756                  (IV)HvAUX(sv)->xhv_name_count
1757                 );
1758             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1759                 const I32 count = HvAUX(sv)->xhv_name_count;
1760                 if (count) {
1761                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1762                     /* The starting point is the first element if count is
1763                        positive and the second element if count is negative. */
1764                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1765                         + (count < 0 ? 1 : 0);
1766                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1767                         + (count < 0 ? -count : count);
1768                     while (hekp < endp) {
1769                         if (*hekp) {
1770                             sv_catpvs(names, ", \"");
1771                             sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1772                             sv_catpvs(names, "\"");
1773                         } else {
1774                             /* This should never happen. */
1775                             sv_catpvs(names, ", (null)");
1776                         }
1777                         ++hekp;
1778                     }
1779                     Perl_dump_indent(aTHX_
1780                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1781                     );
1782                 }
1783                 else
1784                     Perl_dump_indent(aTHX_
1785                      level, file, "  ENAME = \"%s\"\n", HvENAME_get(sv)
1786                     );
1787             }
1788             if (backrefs) {
1789                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1790                                  PTR2UV(backrefs));
1791                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1792                            dumpops, pvlim);
1793             }
1794             if (meta) {
1795                 /* FIXME - mro_algs kflags can signal a UTF-8 name.  */
1796                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1797                                  (int)meta->mro_which->length,
1798                                  meta->mro_which->name,
1799                                  PTR2UV(meta->mro_which));
1800                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1801                                  (UV)meta->cache_gen);
1802                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1803                                  (UV)meta->pkg_gen);
1804                 if (meta->mro_linear_all) {
1805                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1806                                  PTR2UV(meta->mro_linear_all));
1807                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1808                            dumpops, pvlim);
1809                 }
1810                 if (meta->mro_linear_current) {
1811                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1812                                  PTR2UV(meta->mro_linear_current));
1813                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1814                            dumpops, pvlim);
1815                 }
1816                 if (meta->mro_nextmethod) {
1817                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1818                                  PTR2UV(meta->mro_nextmethod));
1819                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1820                            dumpops, pvlim);
1821                 }
1822                 if (meta->isa) {
1823                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1824                                  PTR2UV(meta->isa));
1825                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1826                            dumpops, pvlim);
1827                 }
1828             }
1829         }
1830         if (nest < maxnest) {
1831             HV * const hv = MUTABLE_HV(sv);
1832             STRLEN i;
1833             HE *he;
1834
1835             if (HvARRAY(hv)) {
1836                 int count = maxnest - nest;
1837                 for (i=0; i <= HvMAX(hv); i++) {
1838                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1839                         U32 hash;
1840                         SV * keysv;
1841                         const char * keypv;
1842                         SV * elt;
1843                 STRLEN len;
1844
1845                         if (count-- <= 0) goto DONEHV;
1846
1847                         hash = HeHASH(he);
1848                         keysv = hv_iterkeysv(he);
1849                         keypv = SvPV_const(keysv, len);
1850                         elt = HeVAL(he);
1851
1852                 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1853                 if (SvUTF8(keysv))
1854                     PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1855                         if (HvEITER_get(hv) == he)
1856                             PerlIO_printf(file, "[CURRENT] ");
1857                 if (HeKREHASH(he))
1858                     PerlIO_printf(file, "[REHASH] ");
1859                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1860                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1861             }
1862                 }
1863               DONEHV:;
1864             }
1865         }
1866         break;
1867
1868     case SVt_PVCV:
1869         if (CvAUTOLOAD(sv)) {
1870             STRLEN len;
1871             const char *const name =  SvPV_const(sv, len);
1872             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%.*s\"\n",
1873                              (int) len, name);
1874         }
1875         if (SvPOK(sv)) {
1876             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1877                              (int) CvPROTOLEN(sv), CvPROTO(sv));
1878         }
1879         /* FALL THROUGH */
1880     case SVt_PVFM:
1881         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1882         if (!CvISXSUB(sv)) {
1883             if (CvSTART(sv)) {
1884                 Perl_dump_indent(aTHX_ level, file,
1885                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1886                                  PTR2UV(CvSTART(sv)),
1887                                  (IV)sequence_num(CvSTART(sv)));
1888             }
1889             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1890                              PTR2UV(CvROOT(sv)));
1891             if (CvROOT(sv) && dumpops) {
1892                 do_op_dump(level+1, file, CvROOT(sv));
1893             }
1894         } else {
1895             SV * const constant = cv_const_sv((const CV *)sv);
1896
1897             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1898
1899             if (constant) {
1900                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1901                                  " (CONST SV)\n",
1902                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1903                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1904                            pvlim);
1905             } else {
1906                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1907                                  (IV)CvXSUBANY(sv).any_i32);
1908             }
1909         }
1910         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1911         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1912         if (type == SVt_PVCV)
1913             Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1914         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1915         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1916         if (type == SVt_PVFM)
1917             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
1918         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1919         if (nest < maxnest) {
1920             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1921         }
1922         {
1923             const CV * const outside = CvOUTSIDE(sv);
1924             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1925                         PTR2UV(outside),
1926                         (!outside ? "null"
1927                          : CvANON(outside) ? "ANON"
1928                          : (outside == PL_main_cv) ? "MAIN"
1929                          : CvUNIQUE(outside) ? "UNIQUE"
1930                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1931         }
1932         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1933             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1934         break;
1935
1936     case SVt_PVGV:
1937     case SVt_PVLV:
1938         if (type == SVt_PVLV) {
1939             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
1940             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1941             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1942             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1943             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
1944             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1945                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1946                     dumpops, pvlim);
1947         }
1948         if (!isGV_with_GP(sv))
1949             break;
1950         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
1951         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1952         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
1953         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1954         if (!GvGP(sv))
1955             break;
1956         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1957         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1958         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1959         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
1960         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1961         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1962         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1963         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1964         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
1965         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
1966         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1967         do_gv_dump (level, file, "    EGV", GvEGV(sv));
1968         break;
1969     case SVt_PVIO:
1970         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1971         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1972         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1973         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
1974         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1975         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1976         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1977         if (IoTOP_NAME(sv))
1978             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1979         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1980             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
1981         else {
1982             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
1983                              PTR2UV(IoTOP_GV(sv)));
1984             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1985                         maxnest, dumpops, pvlim);
1986         }
1987         /* Source filters hide things that are not GVs in these three, so let's
1988            be careful out there.  */
1989         if (IoFMT_NAME(sv))
1990             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1991         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1992             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
1993         else {
1994             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
1995                              PTR2UV(IoFMT_GV(sv)));
1996             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1997                         maxnest, dumpops, pvlim);
1998         }
1999         if (IoBOTTOM_NAME(sv))
2000             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2001         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2002             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2003         else {
2004             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2005                              PTR2UV(IoBOTTOM_GV(sv)));
2006             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2007                         maxnest, dumpops, pvlim);
2008         }
2009         if (isPRINT(IoTYPE(sv)))
2010             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2011         else
2012             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2013         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2014         break;
2015     case SVt_REGEXP:
2016         {
2017             struct regexp * const r = (struct regexp *)SvANY(sv);
2018             flags = RX_EXTFLAGS((REGEXP*)sv);
2019             sv_setpv(d,"");
2020             append_flags(d, flags, regexp_flags_names);
2021             if (*(SvEND(d) - 1) == ',') {
2022                 SvCUR_set(d, SvCUR(d) - 1);
2023                 SvPVX(d)[SvCUR(d)] = '\0';
2024             }
2025             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2026                                 (UV)flags, SvPVX_const(d));
2027             Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2028                                 (UV)(r->intflags));
2029             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2030                                 (UV)(r->nparens));
2031             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2032                                 (UV)(r->lastparen));
2033             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2034                                 (UV)(r->lastcloseparen));
2035             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2036                                 (IV)(r->minlen));
2037             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2038                                 (IV)(r->minlenret));
2039             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2040                                 (UV)(r->gofs));
2041             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2042                                 (UV)(r->pre_prefix));
2043             Perl_dump_indent(aTHX_ level, file, "  SEEN_EVALS = %"UVuf"\n",
2044                                 (UV)(r->seen_evals));
2045             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2046                                 (IV)(r->sublen));
2047             if (r->subbeg)
2048                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2049                             PTR2UV(r->subbeg),
2050                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2051             else
2052                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2053             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf"\n",
2054                                 PTR2UV(r->engine));
2055             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2056                                 PTR2UV(r->mother_re));
2057             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2058                                 PTR2UV(r->paren_names));
2059             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2060                                 PTR2UV(r->substrs));
2061             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2062                                 PTR2UV(r->pprivate));
2063             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2064                                 PTR2UV(r->offs));
2065 #ifdef PERL_OLD_COPY_ON_WRITE
2066             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2067                                 PTR2UV(r->saved_copy));
2068 #endif
2069         }
2070         break;
2071     }
2072     SvREFCNT_dec(d);
2073 }
2074
2075 void
2076 Perl_sv_dump(pTHX_ SV *sv)
2077 {
2078     dVAR;
2079
2080     PERL_ARGS_ASSERT_SV_DUMP;
2081
2082     if (SvROK(sv))
2083         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2084     else
2085         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2086 }
2087
2088 int
2089 Perl_runops_debug(pTHX)
2090 {
2091     dVAR;
2092     if (!PL_op) {
2093         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2094         return 0;
2095     }
2096
2097     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2098     do {
2099         if (PL_debug) {
2100             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2101                 PerlIO_printf(Perl_debug_log,
2102                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2103                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2104                               PTR2UV(*PL_watchaddr));
2105             if (DEBUG_s_TEST_) {
2106                 if (DEBUG_v_TEST_) {
2107                     PerlIO_printf(Perl_debug_log, "\n");
2108                     deb_stack_all();
2109                 }
2110                 else
2111                     debstack();
2112             }
2113
2114
2115             if (DEBUG_t_TEST_) debop(PL_op);
2116             if (DEBUG_P_TEST_) debprof(PL_op);
2117         }
2118     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2119     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2120
2121     TAINT_NOT;
2122     return 0;
2123 }
2124
2125 I32
2126 Perl_debop(pTHX_ const OP *o)
2127 {
2128     dVAR;
2129
2130     PERL_ARGS_ASSERT_DEBOP;
2131
2132     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2133         return 0;
2134
2135     Perl_deb(aTHX_ "%s", OP_NAME(o));
2136     switch (o->op_type) {
2137     case OP_CONST:
2138     case OP_HINTSEVAL:
2139         /* With ITHREADS, consts are stored in the pad, and the right pad
2140          * may not be active here, so check.
2141          * Looks like only during compiling the pads are illegal.
2142          */
2143 #ifdef USE_ITHREADS
2144         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2145 #endif
2146             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2147         break;
2148     case OP_GVSV:
2149     case OP_GV:
2150         if (cGVOPo_gv) {
2151             SV * const sv = newSV(0);
2152 #ifdef PERL_MAD
2153             /* FIXME - is this making unwarranted assumptions about the
2154                UTF-8 cleanliness of the dump file handle?  */
2155             SvUTF8_on(sv);
2156 #endif
2157             gv_fullname3(sv, cGVOPo_gv, NULL);
2158             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2159             SvREFCNT_dec(sv);
2160         }
2161         else
2162             PerlIO_printf(Perl_debug_log, "(NULL)");
2163         break;
2164     case OP_PADSV:
2165     case OP_PADAV:
2166     case OP_PADHV:
2167         {
2168         /* print the lexical's name */
2169         CV * const cv = deb_curcv(cxstack_ix);
2170         SV *sv;
2171         if (cv) {
2172             AV * const padlist = CvPADLIST(cv);
2173             AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2174             sv = *av_fetch(comppad, o->op_targ, FALSE);
2175         } else
2176             sv = NULL;
2177         if (sv)
2178             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2179         else
2180             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2181         }
2182         break;
2183     default:
2184         break;
2185     }
2186     PerlIO_printf(Perl_debug_log, "\n");
2187     return 0;
2188 }
2189
2190 STATIC CV*
2191 S_deb_curcv(pTHX_ const I32 ix)
2192 {
2193     dVAR;
2194     const PERL_CONTEXT * const cx = &cxstack[ix];
2195     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2196         return cx->blk_sub.cv;
2197     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2198         return cx->blk_eval.cv;
2199     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2200         return PL_main_cv;
2201     else if (ix <= 0)
2202         return NULL;
2203     else
2204         return deb_curcv(ix - 1);
2205 }
2206
2207 void
2208 Perl_watch(pTHX_ char **addr)
2209 {
2210     dVAR;
2211
2212     PERL_ARGS_ASSERT_WATCH;
2213
2214     PL_watchaddr = addr;
2215     PL_watchok = *addr;
2216     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2217         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2218 }
2219
2220 STATIC void
2221 S_debprof(pTHX_ const OP *o)
2222 {
2223     dVAR;
2224
2225     PERL_ARGS_ASSERT_DEBPROF;
2226
2227     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2228         return;
2229     if (!PL_profiledata)
2230         Newxz(PL_profiledata, MAXO, U32);
2231     ++PL_profiledata[o->op_type];
2232 }
2233
2234 void
2235 Perl_debprofdump(pTHX)
2236 {
2237     dVAR;
2238     unsigned i;
2239     if (!PL_profiledata)
2240         return;
2241     for (i = 0; i < MAXO; i++) {
2242         if (PL_profiledata[i])
2243             PerlIO_printf(Perl_debug_log,
2244                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2245                                        PL_op_name[i]);
2246     }
2247 }
2248
2249 #ifdef PERL_MAD
2250 /*
2251  *    XML variants of most of the above routines
2252  */
2253
2254 STATIC void
2255 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2256 {
2257     va_list args;
2258
2259     PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2260
2261     PerlIO_printf(file, "\n    ");
2262     va_start(args, pat);
2263     xmldump_vindent(level, file, pat, &args);
2264     va_end(args);
2265 }
2266
2267
2268 void
2269 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2270 {
2271     va_list args;
2272     PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2273     va_start(args, pat);
2274     xmldump_vindent(level, file, pat, &args);
2275     va_end(args);
2276 }
2277
2278 void
2279 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2280 {
2281     PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2282
2283     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2284     PerlIO_vprintf(file, pat, *args);
2285 }
2286
2287 void
2288 Perl_xmldump_all(pTHX)
2289 {
2290     xmldump_all_perl(FALSE);
2291 }
2292
2293 void
2294 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2295 {
2296     PerlIO_setlinebuf(PL_xmlfp);
2297     if (PL_main_root)
2298         op_xmldump(PL_main_root);
2299     /* someday we might call this, when it outputs XML: */
2300     /* xmldump_packsubs_perl(PL_defstash, justperl); */
2301     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2302         PerlIO_close(PL_xmlfp);
2303     PL_xmlfp = 0;
2304 }
2305
2306 void
2307 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2308 {
2309     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2310     xmldump_packsubs_perl(stash, FALSE);
2311 }
2312
2313 void
2314 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2315 {
2316     I32 i;
2317     HE  *entry;
2318
2319     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2320
2321     if (!HvARRAY(stash))
2322         return;
2323     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2324         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2325             GV *gv = MUTABLE_GV(HeVAL(entry));
2326             HV *hv;
2327             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2328                 continue;
2329             if (GvCVu(gv))
2330                 xmldump_sub_perl(gv, justperl);
2331             if (GvFORM(gv))
2332                 xmldump_form(gv);
2333             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2334                 && (hv = GvHV(gv)) && hv != PL_defstash)
2335                 xmldump_packsubs_perl(hv, justperl);    /* nested package */
2336         }
2337     }
2338 }
2339
2340 void
2341 Perl_xmldump_sub(pTHX_ const GV *gv)
2342 {
2343     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2344     xmldump_sub_perl(gv, FALSE);
2345 }
2346
2347 void
2348 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2349 {
2350     SV * sv;
2351
2352     PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2353
2354     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2355         return;
2356
2357     sv = sv_newmortal();
2358     gv_fullname3(sv, gv, NULL);
2359     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2360     if (CvXSUB(GvCV(gv)))
2361         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2362             PTR2UV(CvXSUB(GvCV(gv))),
2363             (int)CvXSUBANY(GvCV(gv)).any_i32);
2364     else if (CvROOT(GvCV(gv)))
2365         op_xmldump(CvROOT(GvCV(gv)));
2366     else
2367         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2368 }
2369
2370 void
2371 Perl_xmldump_form(pTHX_ const GV *gv)
2372 {
2373     SV * const sv = sv_newmortal();
2374
2375     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2376
2377     gv_fullname3(sv, gv, NULL);
2378     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2379     if (CvROOT(GvFORM(gv)))
2380         op_xmldump(CvROOT(GvFORM(gv)));
2381     else
2382         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2383 }
2384
2385 void
2386 Perl_xmldump_eval(pTHX)
2387 {
2388     op_xmldump(PL_eval_root);
2389 }
2390
2391 char *
2392 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2393 {
2394     PERL_ARGS_ASSERT_SV_CATXMLSV;
2395     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2396 }
2397
2398 char *
2399 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2400 {
2401     PERL_ARGS_ASSERT_SV_CATXMLPV;
2402     return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2403 }
2404
2405 char *
2406 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2407 {
2408     unsigned int c;
2409     const char * const e = pv + len;
2410     const char * const start = pv;
2411     STRLEN dsvcur;
2412     STRLEN cl;
2413
2414     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2415
2416     sv_catpvs(dsv,"");
2417     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2418
2419   retry:
2420     while (pv < e) {
2421         if (utf8) {
2422             c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2423             if (cl == 0) {
2424                 SvCUR(dsv) = dsvcur;
2425                 pv = start;
2426                 utf8 = 0;
2427                 goto retry;
2428             }
2429         }
2430         else
2431             c = (*pv & 255);
2432
2433         switch (c) {
2434         case 0x00:
2435         case 0x01:
2436         case 0x02:
2437         case 0x03:
2438         case 0x04:
2439         case 0x05:
2440         case 0x06:
2441         case 0x07:
2442         case 0x08:
2443         case 0x0b:
2444         case 0x0c:
2445         case 0x0e:
2446         case 0x0f:
2447         case 0x10:
2448         case 0x11:
2449         case 0x12:
2450         case 0x13:
2451         case 0x14:
2452         case 0x15:
2453         case 0x16:
2454         case 0x17:
2455         case 0x18:
2456         case 0x19:
2457         case 0x1a:
2458         case 0x1b:
2459         case 0x1c:
2460         case 0x1d:
2461         case 0x1e:
2462         case 0x1f:
2463         case 0x7f:
2464         case 0x80:
2465         case 0x81:
2466         case 0x82:
2467         case 0x83:
2468         case 0x84:
2469         case 0x86:
2470         case 0x87:
2471         case 0x88:
2472         case 0x89:
2473         case 0x90:
2474         case 0x91:
2475         case 0x92:
2476         case 0x93:
2477         case 0x94:
2478         case 0x95:
2479         case 0x96:
2480         case 0x97:
2481         case 0x98:
2482         case 0x99:
2483         case 0x9a:
2484         case 0x9b:
2485         case 0x9c:
2486         case 0x9d:
2487         case 0x9e:
2488         case 0x9f:
2489             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2490             break;
2491         case '<':
2492             sv_catpvs(dsv, "&lt;");
2493             break;
2494         case '>':
2495             sv_catpvs(dsv, "&gt;");
2496             break;
2497         case '&':
2498             sv_catpvs(dsv, "&amp;");
2499             break;
2500         case '"':
2501             sv_catpvs(dsv, "&#34;");
2502             break;
2503         default:
2504             if (c < 0xD800) {
2505                 if (c < 32 || c > 127) {
2506                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2507                 }
2508                 else {
2509                     const char string = (char) c;
2510                     sv_catpvn(dsv, &string, 1);
2511                 }
2512                 break;
2513             }
2514             if ((c >= 0xD800 && c <= 0xDB7F) ||
2515                 (c >= 0xDC00 && c <= 0xDFFF) ||
2516                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2517                  c > 0x10ffff)
2518                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2519             else
2520                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2521         }
2522
2523         if (utf8)
2524             pv += UTF8SKIP(pv);
2525         else
2526             pv++;
2527     }
2528
2529     return SvPVX(dsv);
2530 }
2531
2532 char *
2533 Perl_sv_xmlpeek(pTHX_ SV *sv)
2534 {
2535     SV * const t = sv_newmortal();
2536     STRLEN n_a;
2537     int unref = 0;
2538
2539     PERL_ARGS_ASSERT_SV_XMLPEEK;
2540
2541     sv_utf8_upgrade(t);
2542     sv_setpvs(t, "");
2543     /* retry: */
2544     if (!sv) {
2545         sv_catpv(t, "VOID=\"\"");
2546         goto finish;
2547     }
2548     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2549         sv_catpv(t, "WILD=\"\"");
2550         goto finish;
2551     }
2552     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2553         if (sv == &PL_sv_undef) {
2554             sv_catpv(t, "SV_UNDEF=\"1\"");
2555             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2556                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2557                 SvREADONLY(sv))
2558                 goto finish;
2559         }
2560         else if (sv == &PL_sv_no) {
2561             sv_catpv(t, "SV_NO=\"1\"");
2562             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2563                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2564                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2565                                   SVp_POK|SVp_NOK)) &&
2566                 SvCUR(sv) == 0 &&
2567                 SvNVX(sv) == 0.0)
2568                 goto finish;
2569         }
2570         else if (sv == &PL_sv_yes) {
2571             sv_catpv(t, "SV_YES=\"1\"");
2572             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2573                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2574                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2575                                   SVp_POK|SVp_NOK)) &&
2576                 SvCUR(sv) == 1 &&
2577                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2578                 SvNVX(sv) == 1.0)
2579                 goto finish;
2580         }
2581         else {
2582             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2583             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2584                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2585                 SvREADONLY(sv))
2586                 goto finish;
2587         }
2588         sv_catpv(t, " XXX=\"\" ");
2589     }
2590     else if (SvREFCNT(sv) == 0) {
2591         sv_catpv(t, " refcnt=\"0\"");
2592         unref++;
2593     }
2594     else if (DEBUG_R_TEST_) {
2595         int is_tmp = 0;
2596         I32 ix;
2597         /* is this SV on the tmps stack? */
2598         for (ix=PL_tmps_ix; ix>=0; ix--) {
2599             if (PL_tmps_stack[ix] == sv) {
2600                 is_tmp = 1;
2601                 break;
2602             }
2603         }
2604         if (SvREFCNT(sv) > 1)
2605             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2606                     is_tmp ? "T" : "");
2607         else if (is_tmp)
2608             sv_catpv(t, " DRT=\"<T>\"");
2609     }
2610
2611     if (SvROK(sv)) {
2612         sv_catpv(t, " ROK=\"\"");
2613     }
2614     switch (SvTYPE(sv)) {
2615     default:
2616         sv_catpv(t, " FREED=\"1\"");
2617         goto finish;
2618
2619     case SVt_NULL:
2620         sv_catpv(t, " UNDEF=\"1\"");
2621         goto finish;
2622     case SVt_IV:
2623         sv_catpv(t, " IV=\"");
2624         break;
2625     case SVt_NV:
2626         sv_catpv(t, " NV=\"");
2627         break;
2628     case SVt_PV:
2629         sv_catpv(t, " PV=\"");
2630         break;
2631     case SVt_PVIV:
2632         sv_catpv(t, " PVIV=\"");
2633         break;
2634     case SVt_PVNV:
2635         sv_catpv(t, " PVNV=\"");
2636         break;
2637     case SVt_PVMG:
2638         sv_catpv(t, " PVMG=\"");
2639         break;
2640     case SVt_PVLV:
2641         sv_catpv(t, " PVLV=\"");
2642         break;
2643     case SVt_PVAV:
2644         sv_catpv(t, " AV=\"");
2645         break;
2646     case SVt_PVHV:
2647         sv_catpv(t, " HV=\"");
2648         break;
2649     case SVt_PVCV:
2650         if (CvGV(sv))
2651             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2652         else
2653             sv_catpv(t, " CV=\"()\"");
2654         goto finish;
2655     case SVt_PVGV:
2656         sv_catpv(t, " GV=\"");
2657         break;
2658     case SVt_BIND:
2659         sv_catpv(t, " BIND=\"");
2660         break;
2661     case SVt_REGEXP:
2662         sv_catpv(t, " REGEXP=\"");
2663         break;
2664     case SVt_PVFM:
2665         sv_catpv(t, " FM=\"");
2666         break;
2667     case SVt_PVIO:
2668         sv_catpv(t, " IO=\"");
2669         break;
2670     }
2671
2672     if (SvPOKp(sv)) {
2673         if (SvPVX(sv)) {
2674             sv_catxmlsv(t, sv);
2675         }
2676     }
2677     else if (SvNOKp(sv)) {
2678         STORE_NUMERIC_LOCAL_SET_STANDARD();
2679         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2680         RESTORE_NUMERIC_LOCAL();
2681     }
2682     else if (SvIOKp(sv)) {
2683         if (SvIsUV(sv))
2684             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2685         else
2686             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2687     }
2688     else
2689         sv_catpv(t, "");
2690     sv_catpv(t, "\"");
2691
2692   finish:
2693     while (unref--)
2694         sv_catpv(t, ")");
2695     return SvPV(t, n_a);
2696 }
2697
2698 void
2699 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2700 {
2701     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2702
2703     if (!pm) {
2704         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2705         return;
2706     }
2707     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2708     level++;
2709     if (PM_GETRE(pm)) {
2710         REGEXP *const r = PM_GETRE(pm);
2711         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2712         sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2713         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2714              SvPVX(tmpsv));
2715         SvREFCNT_dec(tmpsv);
2716         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2717              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2718     }
2719     else
2720         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2721     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2722         SV * const tmpsv = pm_description(pm);
2723         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2724         SvREFCNT_dec(tmpsv);
2725     }
2726
2727     level--;
2728     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2729         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2730         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2731         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2732         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2733         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2734     }
2735     else
2736         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2737 }
2738
2739 void
2740 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2741 {
2742     do_pmop_xmldump(0, PL_xmlfp, pm);
2743 }
2744
2745 void
2746 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2747 {
2748     UV      seq;
2749     int     contents = 0;
2750
2751     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2752
2753     if (!o)
2754         return;
2755     seq = sequence_num(o);
2756     Perl_xmldump_indent(aTHX_ level, file,
2757         "<op_%s seq=\"%"UVuf" -> ",
2758              OP_NAME(o),
2759                       seq);
2760     level++;
2761     if (o->op_next)
2762         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2763                       sequence_num(o->op_next));
2764     else
2765         PerlIO_printf(file, "DONE\"");
2766
2767     if (o->op_targ) {
2768         if (o->op_type == OP_NULL)
2769         {
2770             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2771             if (o->op_targ == OP_NEXTSTATE)
2772             {
2773                 if (CopLINE(cCOPo))
2774                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2775                                      (UV)CopLINE(cCOPo));
2776                 if (CopSTASHPV(cCOPo))
2777                     PerlIO_printf(file, " package=\"%s\"",
2778                                      CopSTASHPV(cCOPo));
2779                 if (CopLABEL(cCOPo))
2780                     PerlIO_printf(file, " label=\"%s\"",
2781                                      CopLABEL(cCOPo));
2782             }
2783         }
2784         else
2785             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2786     }
2787 #ifdef DUMPADDR
2788     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2789 #endif
2790     if (o->op_flags) {
2791         SV * const tmpsv = newSVpvs("");
2792         switch (o->op_flags & OPf_WANT) {
2793         case OPf_WANT_VOID:
2794             sv_catpv(tmpsv, ",VOID");
2795             break;
2796         case OPf_WANT_SCALAR:
2797             sv_catpv(tmpsv, ",SCALAR");
2798             break;
2799         case OPf_WANT_LIST:
2800             sv_catpv(tmpsv, ",LIST");
2801             break;
2802         default:
2803             sv_catpv(tmpsv, ",UNKNOWN");
2804             break;
2805         }
2806         if (o->op_flags & OPf_KIDS)
2807             sv_catpv(tmpsv, ",KIDS");
2808         if (o->op_flags & OPf_PARENS)
2809             sv_catpv(tmpsv, ",PARENS");
2810         if (o->op_flags & OPf_STACKED)
2811             sv_catpv(tmpsv, ",STACKED");
2812         if (o->op_flags & OPf_REF)
2813             sv_catpv(tmpsv, ",REF");
2814         if (o->op_flags & OPf_MOD)
2815             sv_catpv(tmpsv, ",MOD");
2816         if (o->op_flags & OPf_SPECIAL)
2817             sv_catpv(tmpsv, ",SPECIAL");
2818         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2819         SvREFCNT_dec(tmpsv);
2820     }
2821     if (o->op_private) {
2822         SV * const tmpsv = newSVpvs("");
2823         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2824             if (o->op_private & OPpTARGET_MY)
2825                 sv_catpv(tmpsv, ",TARGET_MY");
2826         }
2827         else if (o->op_type == OP_LEAVESUB ||
2828                  o->op_type == OP_LEAVE ||
2829                  o->op_type == OP_LEAVESUBLV ||
2830                  o->op_type == OP_LEAVEWRITE) {
2831             if (o->op_private & OPpREFCOUNTED)
2832                 sv_catpv(tmpsv, ",REFCOUNTED");
2833         }
2834         else if (o->op_type == OP_AASSIGN) {
2835             if (o->op_private & OPpASSIGN_COMMON)
2836                 sv_catpv(tmpsv, ",COMMON");
2837         }
2838         else if (o->op_type == OP_SASSIGN) {
2839             if (o->op_private & OPpASSIGN_BACKWARDS)
2840                 sv_catpv(tmpsv, ",BACKWARDS");
2841         }
2842         else if (o->op_type == OP_TRANS) {
2843             if (o->op_private & OPpTRANS_SQUASH)
2844                 sv_catpv(tmpsv, ",SQUASH");
2845             if (o->op_private & OPpTRANS_DELETE)
2846                 sv_catpv(tmpsv, ",DELETE");
2847             if (o->op_private & OPpTRANS_COMPLEMENT)
2848                 sv_catpv(tmpsv, ",COMPLEMENT");
2849             if (o->op_private & OPpTRANS_IDENTICAL)
2850                 sv_catpv(tmpsv, ",IDENTICAL");
2851             if (o->op_private & OPpTRANS_GROWS)
2852                 sv_catpv(tmpsv, ",GROWS");
2853         }
2854         else if (o->op_type == OP_REPEAT) {
2855             if (o->op_private & OPpREPEAT_DOLIST)
2856                 sv_catpv(tmpsv, ",DOLIST");
2857         }
2858         else if (o->op_type == OP_ENTERSUB ||
2859                  o->op_type == OP_RV2SV ||
2860                  o->op_type == OP_GVSV ||
2861                  o->op_type == OP_RV2AV ||
2862                  o->op_type == OP_RV2HV ||
2863                  o->op_type == OP_RV2GV ||
2864                  o->op_type == OP_AELEM ||
2865                  o->op_type == OP_HELEM )
2866         {
2867             if (o->op_type == OP_ENTERSUB) {
2868                 if (o->op_private & OPpENTERSUB_AMPER)
2869                     sv_catpv(tmpsv, ",AMPER");
2870                 if (o->op_private & OPpENTERSUB_DB)
2871                     sv_catpv(tmpsv, ",DB");
2872                 if (o->op_private & OPpENTERSUB_HASTARG)
2873                     sv_catpv(tmpsv, ",HASTARG");
2874                 if (o->op_private & OPpENTERSUB_NOPAREN)
2875                     sv_catpv(tmpsv, ",NOPAREN");
2876                 if (o->op_private & OPpENTERSUB_INARGS)
2877                     sv_catpv(tmpsv, ",INARGS");
2878             }
2879             else {
2880                 switch (o->op_private & OPpDEREF) {
2881             case OPpDEREF_SV:
2882                 sv_catpv(tmpsv, ",SV");
2883                 break;
2884             case OPpDEREF_AV:
2885                 sv_catpv(tmpsv, ",AV");
2886                 break;
2887             case OPpDEREF_HV:
2888                 sv_catpv(tmpsv, ",HV");
2889                 break;
2890             }
2891                 if (o->op_private & OPpMAYBE_LVSUB)
2892                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2893             }
2894             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2895                 if (o->op_private & OPpLVAL_DEFER)
2896                     sv_catpv(tmpsv, ",LVAL_DEFER");
2897             }
2898             else {
2899                 if (o->op_private & HINT_STRICT_REFS)
2900                     sv_catpv(tmpsv, ",STRICT_REFS");
2901                 if (o->op_private & OPpOUR_INTRO)
2902                     sv_catpv(tmpsv, ",OUR_INTRO");
2903             }
2904         }
2905         else if (o->op_type == OP_CONST) {
2906             if (o->op_private & OPpCONST_BARE)
2907                 sv_catpv(tmpsv, ",BARE");
2908             if (o->op_private & OPpCONST_STRICT)
2909                 sv_catpv(tmpsv, ",STRICT");
2910             if (o->op_private & OPpCONST_ENTERED)
2911                 sv_catpv(tmpsv, ",ENTERED");
2912         }
2913         else if (o->op_type == OP_FLIP) {
2914             if (o->op_private & OPpFLIP_LINENUM)
2915                 sv_catpv(tmpsv, ",LINENUM");
2916         }
2917         else if (o->op_type == OP_FLOP) {
2918             if (o->op_private & OPpFLIP_LINENUM)
2919                 sv_catpv(tmpsv, ",LINENUM");
2920         }
2921         else if (o->op_type == OP_RV2CV) {
2922             if (o->op_private & OPpLVAL_INTRO)
2923                 sv_catpv(tmpsv, ",INTRO");
2924         }
2925         else if (o->op_type == OP_GV) {
2926             if (o->op_private & OPpEARLY_CV)
2927                 sv_catpv(tmpsv, ",EARLY_CV");
2928         }
2929         else if (o->op_type == OP_LIST) {
2930             if (o->op_private & OPpLIST_GUESSED)
2931                 sv_catpv(tmpsv, ",GUESSED");
2932         }
2933         else if (o->op_type == OP_DELETE) {
2934             if (o->op_private & OPpSLICE)
2935                 sv_catpv(tmpsv, ",SLICE");
2936         }
2937         else if (o->op_type == OP_EXISTS) {
2938             if (o->op_private & OPpEXISTS_SUB)
2939                 sv_catpv(tmpsv, ",EXISTS_SUB");
2940         }
2941         else if (o->op_type == OP_SORT) {
2942             if (o->op_private & OPpSORT_NUMERIC)
2943                 sv_catpv(tmpsv, ",NUMERIC");
2944             if (o->op_private & OPpSORT_INTEGER)
2945                 sv_catpv(tmpsv, ",INTEGER");
2946             if (o->op_private & OPpSORT_REVERSE)
2947                 sv_catpv(tmpsv, ",REVERSE");
2948         }
2949         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2950             if (o->op_private & OPpOPEN_IN_RAW)
2951                 sv_catpv(tmpsv, ",IN_RAW");
2952             if (o->op_private & OPpOPEN_IN_CRLF)
2953                 sv_catpv(tmpsv, ",IN_CRLF");
2954             if (o->op_private & OPpOPEN_OUT_RAW)
2955                 sv_catpv(tmpsv, ",OUT_RAW");
2956             if (o->op_private & OPpOPEN_OUT_CRLF)
2957                 sv_catpv(tmpsv, ",OUT_CRLF");
2958         }
2959         else if (o->op_type == OP_EXIT) {
2960             if (o->op_private & OPpEXIT_VMSISH)
2961                 sv_catpv(tmpsv, ",EXIT_VMSISH");
2962             if (o->op_private & OPpHUSH_VMSISH)
2963                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2964         }
2965         else if (o->op_type == OP_DIE) {
2966             if (o->op_private & OPpHUSH_VMSISH)
2967                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2968         }
2969         else if (PL_check[o->op_type] != Perl_ck_ftst) {
2970             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2971                 sv_catpv(tmpsv, ",FT_ACCESS");
2972             if (o->op_private & OPpFT_STACKED)
2973                 sv_catpv(tmpsv, ",FT_STACKED");
2974         }
2975         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2976             sv_catpv(tmpsv, ",INTRO");
2977         if (SvCUR(tmpsv))
2978             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2979         SvREFCNT_dec(tmpsv);
2980     }
2981
2982     switch (o->op_type) {
2983     case OP_AELEMFAST:
2984         if (o->op_flags & OPf_SPECIAL) {
2985             break;
2986         }
2987     case OP_GVSV:
2988     case OP_GV:
2989 #ifdef USE_ITHREADS
2990         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2991 #else
2992         if (cSVOPo->op_sv) {
2993             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2994             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2995             char *s;
2996             STRLEN len;
2997             ENTER;
2998             SAVEFREESV(tmpsv1);
2999             SAVEFREESV(tmpsv2);
3000             gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3001             s = SvPV(tmpsv1,len);
3002             sv_catxmlpvn(tmpsv2, s, len, 1);
3003             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3004             LEAVE;
3005         }
3006         else
3007             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3008 #endif
3009         break;
3010     case OP_CONST:
3011     case OP_HINTSEVAL:
3012     case OP_METHOD_NAMED:
3013 #ifndef USE_ITHREADS
3014         /* with ITHREADS, consts are stored in the pad, and the right pad
3015          * may not be active here, so skip */
3016         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3017 #endif
3018         break;
3019     case OP_ANONCODE:
3020         if (!contents) {
3021             contents = 1;
3022             PerlIO_printf(file, ">\n");
3023         }
3024         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3025         break;
3026     case OP_NEXTSTATE:
3027     case OP_DBSTATE:
3028         if (CopLINE(cCOPo))
3029             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3030                              (UV)CopLINE(cCOPo));
3031         if (CopSTASHPV(cCOPo))
3032             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3033                              CopSTASHPV(cCOPo));
3034         if (CopLABEL(cCOPo))
3035             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3036                              CopLABEL(cCOPo));
3037         break;
3038     case OP_ENTERLOOP:
3039         S_xmldump_attr(aTHX_ level, file, "redo=\"");
3040         if (cLOOPo->op_redoop)
3041             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3042         else
3043             PerlIO_printf(file, "DONE\"");
3044         S_xmldump_attr(aTHX_ level, file, "next=\"");
3045         if (cLOOPo->op_nextop)
3046             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3047         else
3048             PerlIO_printf(file, "DONE\"");
3049         S_xmldump_attr(aTHX_ level, file, "last=\"");
3050         if (cLOOPo->op_lastop)
3051             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3052         else
3053             PerlIO_printf(file, "DONE\"");
3054         break;
3055     case OP_COND_EXPR:
3056     case OP_RANGE:
3057     case OP_MAPWHILE:
3058     case OP_GREPWHILE:
3059     case OP_OR:
3060     case OP_AND:
3061         S_xmldump_attr(aTHX_ level, file, "other=\"");
3062         if (cLOGOPo->op_other)
3063             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3064         else
3065             PerlIO_printf(file, "DONE\"");
3066         break;
3067     case OP_LEAVE:
3068     case OP_LEAVEEVAL:
3069     case OP_LEAVESUB:
3070     case OP_LEAVESUBLV:
3071     case OP_LEAVEWRITE:
3072     case OP_SCOPE:
3073         if (o->op_private & OPpREFCOUNTED)
3074             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3075         break;
3076     default:
3077         break;
3078     }
3079
3080     if (PL_madskills && o->op_madprop) {
3081         char prevkey = '\0';
3082         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3083         const MADPROP* mp = o->op_madprop;
3084
3085         if (!contents) {
3086             contents = 1;
3087             PerlIO_printf(file, ">\n");
3088         }
3089         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3090         level++;
3091         while (mp) {
3092             char tmp = mp->mad_key;
3093             sv_setpvs(tmpsv,"\"");
3094             if (tmp)
3095                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3096             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3097                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3098             else
3099                 prevkey = tmp;
3100             sv_catpv(tmpsv, "\"");
3101             switch (mp->mad_type) {
3102             case MAD_NULL:
3103                 sv_catpv(tmpsv, "NULL");
3104                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3105                 break;
3106             case MAD_PV:
3107                 sv_catpv(tmpsv, " val=\"");
3108                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3109                 sv_catpv(tmpsv, "\"");
3110                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3111                 break;
3112             case MAD_SV:
3113                 sv_catpv(tmpsv, " val=\"");
3114                 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3115                 sv_catpv(tmpsv, "\"");
3116                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3117                 break;
3118             case MAD_OP:
3119                 if ((OP*)mp->mad_val) {
3120                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3121                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3122                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3123                 }
3124                 break;
3125             default:
3126                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3127                 break;
3128             }
3129             mp = mp->mad_next;
3130         }
3131         level--;
3132         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3133
3134         SvREFCNT_dec(tmpsv);
3135     }
3136
3137     switch (o->op_type) {
3138     case OP_PUSHRE:
3139     case OP_MATCH:
3140     case OP_QR:
3141     case OP_SUBST:
3142         if (!contents) {
3143             contents = 1;
3144             PerlIO_printf(file, ">\n");
3145         }
3146         do_pmop_xmldump(level, file, cPMOPo);
3147         break;
3148     default:
3149         break;
3150     }
3151
3152     if (o->op_flags & OPf_KIDS) {
3153         OP *kid;
3154         if (!contents) {
3155             contents = 1;
3156             PerlIO_printf(file, ">\n");
3157         }
3158         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3159             do_op_xmldump(level, file, kid);
3160     }
3161
3162     if (contents)
3163         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3164     else
3165         PerlIO_printf(file, " />\n");
3166 }
3167
3168 void
3169 Perl_op_xmldump(pTHX_ const OP *o)
3170 {
3171     PERL_ARGS_ASSERT_OP_XMLDUMP;
3172
3173     do_op_xmldump(0, PL_xmlfp, o);
3174 }
3175 #endif
3176
3177 /*
3178  * Local variables:
3179  * c-indentation-style: bsd
3180  * c-basic-offset: 4
3181  * indent-tabs-mode: nil
3182  * End:
3183  *
3184  * ex: set ts=8 sts=4 sw=4 et:
3185  */