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