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