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