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