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_tindex(MUTABLE_AV(sv)) >= 0) {
1875             SSize_t count;
1876             for (count = 0; count <=  av_tindex(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         U32 usedkeys;
1887         if (SvOOK(sv)) {
1888             struct xpvhv_aux *const aux = HvAUX(sv);
1889             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %"UVuf"\n",
1890                              (UV)aux->xhv_aux_flags);
1891         }
1892         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1893         usedkeys = HvUSEDKEYS(sv);
1894         if (HvARRAY(sv) && usedkeys) {
1895             /* Show distribution of HEs in the ARRAY */
1896             int freq[200];
1897 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1898             int i;
1899             int max = 0;
1900             U32 pow2 = 2, keys = usedkeys;
1901             NV theoret, sum = 0;
1902
1903             PerlIO_printf(file, "  (");
1904             Zero(freq, FREQ_MAX + 1, int);
1905             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1906                 HE* h;
1907                 int count = 0;
1908                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1909                     count++;
1910                 if (count > FREQ_MAX)
1911                     count = FREQ_MAX;
1912                 freq[count]++;
1913                 if (max < count)
1914                     max = count;
1915             }
1916             for (i = 0; i <= max; i++) {
1917                 if (freq[i]) {
1918                     PerlIO_printf(file, "%d%s:%d", i,
1919                                   (i == FREQ_MAX) ? "+" : "",
1920                                   freq[i]);
1921                     if (i != max)
1922                         PerlIO_printf(file, ", ");
1923                 }
1924             }
1925             PerlIO_putc(file, ')');
1926             /* The "quality" of a hash is defined as the total number of
1927                comparisons needed to access every element once, relative
1928                to the expected number needed for a random hash.
1929
1930                The total number of comparisons is equal to the sum of
1931                the squares of the number of entries in each bucket.
1932                For a random hash of n keys into k buckets, the expected
1933                value is
1934                                 n + n(n-1)/2k
1935             */
1936
1937             for (i = max; i > 0; i--) { /* Precision: count down. */
1938                 sum += freq[i] * i * i;
1939             }
1940             while ((keys = keys >> 1))
1941                 pow2 = pow2 << 1;
1942             theoret = usedkeys;
1943             theoret += theoret * (theoret-1)/pow2;
1944             PerlIO_putc(file, '\n');
1945             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1946         }
1947         PerlIO_putc(file, '\n');
1948         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)usedkeys);
1949         {
1950             STRLEN count = 0;
1951             HE **ents = HvARRAY(sv);
1952
1953             if (ents) {
1954                 HE *const *const last = ents + HvMAX(sv);
1955                 count = last + 1 - ents;
1956
1957                 do {
1958                     if (!*ents)
1959                         --count;
1960                 } while (++ents <= last);
1961             }
1962
1963             if (SvOOK(sv)) {
1964                 struct xpvhv_aux *const aux = HvAUX(sv);
1965                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf
1966                                  " (cached = %"UVuf")\n",
1967                                  (UV)count, (UV)aux->xhv_fill_lazy);
1968             } else {
1969                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
1970                                  (UV)count);
1971             }
1972         }
1973         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1974         if (SvOOK(sv)) {
1975             Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1976             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1977 #ifdef PERL_HASH_RANDOMIZE_KEYS
1978             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1979             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1980                 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1981             }
1982 #endif
1983             PerlIO_putc(file, '\n');
1984         }
1985         {
1986             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1987             if (mg && mg->mg_obj) {
1988                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1989             }
1990         }
1991         {
1992             const char * const hvname = HvNAME_get(sv);
1993             if (hvname) {
1994           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1995      Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1996                                        generic_pv_escape( tmpsv, hvname,
1997                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
1998         }
1999         }
2000         if (SvOOK(sv)) {
2001             AV * const backrefs
2002                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2003             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2004             if (HvAUX(sv)->xhv_name_count)
2005                 Perl_dump_indent(aTHX_
2006                  level, file, "  NAMECOUNT = %"IVdf"\n",
2007                  (IV)HvAUX(sv)->xhv_name_count
2008                 );
2009             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2010                 const I32 count = HvAUX(sv)->xhv_name_count;
2011                 if (count) {
2012                     SV * const names = newSVpvs_flags("", SVs_TEMP);
2013                     /* The starting point is the first element if count is
2014                        positive and the second element if count is negative. */
2015                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2016                         + (count < 0 ? 1 : 0);
2017                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2018                         + (count < 0 ? -count : count);
2019                     while (hekp < endp) {
2020                         if (HEK_LEN(*hekp)) {
2021              SV *tmp = newSVpvs_flags("", SVs_TEMP);
2022                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2023                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2024                         } else {
2025                             /* This should never happen. */
2026                             sv_catpvs(names, ", (null)");
2027                         }
2028                         ++hekp;
2029                     }
2030                     Perl_dump_indent(aTHX_
2031                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
2032                     );
2033                 }
2034                 else {
2035                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2036                     const char *const hvename = HvENAME_get(sv);
2037                     Perl_dump_indent(aTHX_
2038                      level, file, "  ENAME = \"%s\"\n",
2039                      generic_pv_escape(tmp, hvename,
2040                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2041                 }
2042             }
2043             if (backrefs) {
2044                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
2045                                  PTR2UV(backrefs));
2046                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2047                            dumpops, pvlim);
2048             }
2049             if (meta) {
2050                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2051                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"UVxf")\n",
2052                                  generic_pv_escape( tmpsv, meta->mro_which->name,
2053                                 meta->mro_which->length,
2054                                 (meta->mro_which->kflags & HVhek_UTF8)),
2055                                  PTR2UV(meta->mro_which));
2056                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
2057                                  (UV)meta->cache_gen);
2058                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
2059                                  (UV)meta->pkg_gen);
2060                 if (meta->mro_linear_all) {
2061                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
2062                                  PTR2UV(meta->mro_linear_all));
2063                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2064                            dumpops, pvlim);
2065                 }
2066                 if (meta->mro_linear_current) {
2067                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
2068                                  PTR2UV(meta->mro_linear_current));
2069                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2070                            dumpops, pvlim);
2071                 }
2072                 if (meta->mro_nextmethod) {
2073                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
2074                                  PTR2UV(meta->mro_nextmethod));
2075                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2076                            dumpops, pvlim);
2077                 }
2078                 if (meta->isa) {
2079                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
2080                                  PTR2UV(meta->isa));
2081                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2082                            dumpops, pvlim);
2083                 }
2084             }
2085         }
2086         if (nest < maxnest) {
2087             HV * const hv = MUTABLE_HV(sv);
2088             STRLEN i;
2089             HE *he;
2090
2091             if (HvARRAY(hv)) {
2092                 int count = maxnest - nest;
2093                 for (i=0; i <= HvMAX(hv); i++) {
2094                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2095                         U32 hash;
2096                         SV * keysv;
2097                         const char * keypv;
2098                         SV * elt;
2099                         STRLEN len;
2100
2101                         if (count-- <= 0) goto DONEHV;
2102
2103                         hash = HeHASH(he);
2104                         keysv = hv_iterkeysv(he);
2105                         keypv = SvPV_const(keysv, len);
2106                         elt = HeVAL(he);
2107
2108                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2109                         if (SvUTF8(keysv))
2110                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2111                         if (HvEITER_get(hv) == he)
2112                             PerlIO_printf(file, "[CURRENT] ");
2113                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
2114                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2115                     }
2116                 }
2117               DONEHV:;
2118             }
2119         }
2120         break;
2121     } /* case SVt_PVHV */
2122
2123     case SVt_PVCV:
2124         if (CvAUTOLOAD(sv)) {
2125             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2126        STRLEN len;
2127             const char *const name =  SvPV_const(sv, len);
2128             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
2129                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2130         }
2131         if (SvPOK(sv)) {
2132        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2133        const char *const proto = CvPROTO(sv);
2134             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
2135                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2136                                 SvUTF8(sv)));
2137         }
2138         /* FALL THROUGH */
2139     case SVt_PVFM:
2140         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
2141         if (!CvISXSUB(sv)) {
2142             if (CvSTART(sv)) {
2143                 Perl_dump_indent(aTHX_ level, file,
2144                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
2145                                  PTR2UV(CvSTART(sv)),
2146                                  (IV)sequence_num(CvSTART(sv)));
2147             }
2148             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
2149                              PTR2UV(CvROOT(sv)));
2150             if (CvROOT(sv) && dumpops) {
2151                 do_op_dump(level+1, file, CvROOT(sv));
2152             }
2153         } else {
2154             SV * const constant = cv_const_sv((const CV *)sv);
2155
2156             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2157
2158             if (constant) {
2159                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
2160                                  " (CONST SV)\n",
2161                                  PTR2UV(CvXSUBANY(sv).any_ptr));
2162                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2163                            pvlim);
2164             } else {
2165                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
2166                                  (IV)CvXSUBANY(sv).any_i32);
2167             }
2168         }
2169         if (CvNAMED(sv))
2170             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2171                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
2172         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
2173         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
2174         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2175         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2176         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2177         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2178         if (nest < maxnest) {
2179             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2180         }
2181         {
2182             const CV * const outside = CvOUTSIDE(sv);
2183             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
2184                         PTR2UV(outside),
2185                         (!outside ? "null"
2186                          : CvANON(outside) ? "ANON"
2187                          : (outside == PL_main_cv) ? "MAIN"
2188                          : CvUNIQUE(outside) ? "UNIQUE"
2189                          : CvGV(outside) ?
2190                              generic_pv_escape(
2191                                  newSVpvs_flags("", SVs_TEMP),
2192                                  GvNAME(CvGV(outside)),
2193                                  GvNAMELEN(CvGV(outside)),
2194                                  GvNAMEUTF8(CvGV(outside)))
2195                          : "UNDEFINED"));
2196         }
2197         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2198             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2199         break;
2200
2201     case SVt_PVGV:
2202     case SVt_PVLV:
2203         if (type == SVt_PVLV) {
2204             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2205             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2206             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2207             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2208             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2209             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2210                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2211                     dumpops, pvlim);
2212         }
2213         if (isREGEXP(sv)) goto dumpregexp;
2214         if (!isGV_with_GP(sv))
2215             break;
2216        {
2217           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2218           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2219                     generic_pv_escape(tmpsv, GvNAME(sv),
2220                                       GvNAMELEN(sv),
2221                                       GvNAMEUTF8(sv)));
2222        }
2223         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2224         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2225         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2226         if (!GvGP(sv))
2227             break;
2228         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2229         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2230         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2231         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2232         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2233         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2234         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2235         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2236         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2237         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2238         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2239         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2240         break;
2241     case SVt_PVIO:
2242         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2243         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2244         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2245         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2246         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2247         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2248         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2249         if (IoTOP_NAME(sv))
2250             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2251         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2252             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2253         else {
2254             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2255                              PTR2UV(IoTOP_GV(sv)));
2256             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2257                         maxnest, dumpops, pvlim);
2258         }
2259         /* Source filters hide things that are not GVs in these three, so let's
2260            be careful out there.  */
2261         if (IoFMT_NAME(sv))
2262             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2263         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2264             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2265         else {
2266             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2267                              PTR2UV(IoFMT_GV(sv)));
2268             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2269                         maxnest, dumpops, pvlim);
2270         }
2271         if (IoBOTTOM_NAME(sv))
2272             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2273         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2274             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2275         else {
2276             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2277                              PTR2UV(IoBOTTOM_GV(sv)));
2278             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2279                         maxnest, dumpops, pvlim);
2280         }
2281         if (isPRINT(IoTYPE(sv)))
2282             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2283         else
2284             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2285         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2286         break;
2287     case SVt_REGEXP:
2288       dumpregexp:
2289         {
2290             struct regexp * const r = ReANY((REGEXP*)sv);
2291
2292 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2293             sv_setpv(d,"");                                 \
2294             append_flags(d, flags, names);     \
2295             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2296                 SvCUR_set(d, SvCUR(d) - 1);                 \
2297                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2298             }                                               \
2299 } STMT_END
2300             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2301             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
2302                                 (UV)(r->compflags), SvPVX_const(d));
2303
2304             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2305             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2306                                 (UV)(r->extflags), SvPVX_const(d));
2307
2308             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf" (%s)\n",
2309                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2310             if (r->engine == &PL_core_reg_engine) {
2311                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2312                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf" (%s)\n",
2313                                 (UV)(r->intflags), SvPVX_const(d));
2314             } else {
2315                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2316                                 (UV)(r->intflags));
2317             }
2318 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2319             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2320                                 (UV)(r->nparens));
2321             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2322                                 (UV)(r->lastparen));
2323             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2324                                 (UV)(r->lastcloseparen));
2325             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2326                                 (IV)(r->minlen));
2327             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2328                                 (IV)(r->minlenret));
2329             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2330                                 (UV)(r->gofs));
2331             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2332                                 (UV)(r->pre_prefix));
2333             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2334                                 (IV)(r->sublen));
2335             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
2336                                 (IV)(r->suboffset));
2337             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
2338                                 (IV)(r->subcoffset));
2339             if (r->subbeg)
2340                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2341                             PTR2UV(r->subbeg),
2342                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2343             else
2344                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2345             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2346                                 PTR2UV(r->mother_re));
2347             if (nest < maxnest && r->mother_re)
2348                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2349                            maxnest, dumpops, pvlim);
2350             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2351                                 PTR2UV(r->paren_names));
2352             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2353                                 PTR2UV(r->substrs));
2354             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2355                                 PTR2UV(r->pprivate));
2356             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2357                                 PTR2UV(r->offs));
2358             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2359                                 PTR2UV(r->qr_anoncv));
2360 #ifdef PERL_ANY_COW
2361             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2362                                 PTR2UV(r->saved_copy));
2363 #endif
2364         }
2365         break;
2366     }
2367     SvREFCNT_dec_NN(d);
2368 }
2369
2370 /*
2371 =for apidoc sv_dump
2372
2373 Dumps the contents of an SV to the C<STDERR> filehandle.
2374
2375 For an example of its output, see L<Devel::Peek>.
2376
2377 =cut
2378 */
2379
2380 void
2381 Perl_sv_dump(pTHX_ SV *sv)
2382 {
2383     dVAR;
2384
2385     PERL_ARGS_ASSERT_SV_DUMP;
2386
2387     if (SvROK(sv))
2388         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2389     else
2390         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2391 }
2392
2393 int
2394 Perl_runops_debug(pTHX)
2395 {
2396     dVAR;
2397     if (!PL_op) {
2398         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2399         return 0;
2400     }
2401
2402     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2403     do {
2404 #ifdef PERL_TRACE_OPS
2405         ++PL_op_exec_cnt[PL_op->op_type];
2406 #endif
2407         if (PL_debug) {
2408             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2409                 PerlIO_printf(Perl_debug_log,
2410                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2411                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2412                               PTR2UV(*PL_watchaddr));
2413             if (DEBUG_s_TEST_) {
2414                 if (DEBUG_v_TEST_) {
2415                     PerlIO_printf(Perl_debug_log, "\n");
2416                     deb_stack_all();
2417                 }
2418                 else
2419                     debstack();
2420             }
2421
2422
2423             if (DEBUG_t_TEST_) debop(PL_op);
2424             if (DEBUG_P_TEST_) debprof(PL_op);
2425         }
2426
2427         OP_ENTRY_PROBE(OP_NAME(PL_op));
2428     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2429     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2430     PERL_ASYNC_CHECK();
2431
2432     TAINT_NOT;
2433     return 0;
2434 }
2435
2436 I32
2437 Perl_debop(pTHX_ const OP *o)
2438 {
2439     dVAR;
2440
2441     PERL_ARGS_ASSERT_DEBOP;
2442
2443     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2444         return 0;
2445
2446     Perl_deb(aTHX_ "%s", OP_NAME(o));
2447     switch (o->op_type) {
2448     case OP_CONST:
2449     case OP_HINTSEVAL:
2450         /* With ITHREADS, consts are stored in the pad, and the right pad
2451          * may not be active here, so check.
2452          * Looks like only during compiling the pads are illegal.
2453          */
2454 #ifdef USE_ITHREADS
2455         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2456 #endif
2457             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2458         break;
2459     case OP_GVSV:
2460     case OP_GV:
2461         if (cGVOPo_gv) {
2462             SV * const sv = newSV(0);
2463 #ifdef PERL_MAD
2464             /* FIXME - is this making unwarranted assumptions about the
2465                UTF-8 cleanliness of the dump file handle?  */
2466             SvUTF8_on(sv);
2467 #endif
2468             gv_fullname3(sv, cGVOPo_gv, NULL);
2469             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2470             SvREFCNT_dec_NN(sv);
2471         }
2472         else
2473             PerlIO_printf(Perl_debug_log, "(NULL)");
2474         break;
2475
2476     {
2477         int count;
2478
2479     case OP_PADSV:
2480     case OP_PADAV:
2481     case OP_PADHV:
2482         count = 1;
2483         goto dump_padop;
2484     case OP_PADRANGE:
2485         count = o->op_private & OPpPADRANGE_COUNTMASK;
2486     dump_padop:
2487         /* print the lexical's name */
2488         {
2489             CV * const cv = deb_curcv(cxstack_ix);
2490             SV *sv;
2491             PAD * comppad = NULL;
2492             int i;
2493
2494             if (cv) {
2495                 PADLIST * const padlist = CvPADLIST(cv);
2496                 comppad = *PadlistARRAY(padlist);
2497             }
2498             PerlIO_printf(Perl_debug_log, "(");
2499             for (i = 0; i < count; i++) {
2500                 if (comppad &&
2501                         (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2502                     PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2503                 else
2504                     PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2505                             (UV)o->op_targ+i);
2506                 if (i < count-1)
2507                     PerlIO_printf(Perl_debug_log, ",");
2508             }
2509             PerlIO_printf(Perl_debug_log, ")");
2510         }
2511         break;
2512     }
2513
2514     default:
2515         break;
2516     }
2517     PerlIO_printf(Perl_debug_log, "\n");
2518     return 0;
2519 }
2520
2521 STATIC CV*
2522 S_deb_curcv(pTHX_ const I32 ix)
2523 {
2524     dVAR;
2525     const PERL_CONTEXT * const cx = &cxstack[ix];
2526     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2527         return cx->blk_sub.cv;
2528     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2529         return cx->blk_eval.cv;
2530     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2531         return PL_main_cv;
2532     else if (ix <= 0)
2533         return NULL;
2534     else
2535         return deb_curcv(ix - 1);
2536 }
2537
2538 void
2539 Perl_watch(pTHX_ char **addr)
2540 {
2541     dVAR;
2542
2543     PERL_ARGS_ASSERT_WATCH;
2544
2545     PL_watchaddr = addr;
2546     PL_watchok = *addr;
2547     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2548         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2549 }
2550
2551 STATIC void
2552 S_debprof(pTHX_ const OP *o)
2553 {
2554     dVAR;
2555
2556     PERL_ARGS_ASSERT_DEBPROF;
2557
2558     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2559         return;
2560     if (!PL_profiledata)
2561         Newxz(PL_profiledata, MAXO, U32);
2562     ++PL_profiledata[o->op_type];
2563 }
2564
2565 void
2566 Perl_debprofdump(pTHX)
2567 {
2568     dVAR;
2569     unsigned i;
2570     if (!PL_profiledata)
2571         return;
2572     for (i = 0; i < MAXO; i++) {
2573         if (PL_profiledata[i])
2574             PerlIO_printf(Perl_debug_log,
2575                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2576                                        PL_op_name[i]);
2577     }
2578 }
2579
2580 #ifdef PERL_MAD
2581 /*
2582  *    XML variants of most of the above routines
2583  */
2584
2585 STATIC void
2586 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2587 {
2588     va_list args;
2589
2590     PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2591
2592     PerlIO_printf(file, "\n    ");
2593     va_start(args, pat);
2594     xmldump_vindent(level, file, pat, &args);
2595     va_end(args);
2596 }
2597
2598
2599 void
2600 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2601 {
2602     va_list args;
2603     PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2604     va_start(args, pat);
2605     xmldump_vindent(level, file, pat, &args);
2606     va_end(args);
2607 }
2608
2609 void
2610 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2611 {
2612     PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2613
2614     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2615     PerlIO_vprintf(file, pat, *args);
2616 }
2617
2618 void
2619 Perl_xmldump_all(pTHX)
2620 {
2621     xmldump_all_perl(FALSE);
2622 }
2623
2624 void
2625 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2626 {
2627     PerlIO_setlinebuf(PL_xmlfp);
2628     if (PL_main_root)
2629         op_xmldump(PL_main_root);
2630     /* someday we might call this, when it outputs XML: */
2631     /* xmldump_packsubs_perl(PL_defstash, justperl); */
2632     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2633         PerlIO_close(PL_xmlfp);
2634     PL_xmlfp = 0;
2635 }
2636
2637 void
2638 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2639 {
2640     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2641     xmldump_packsubs_perl(stash, FALSE);
2642 }
2643
2644 void
2645 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2646 {
2647     I32 i;
2648     HE  *entry;
2649
2650     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2651
2652     if (!HvARRAY(stash))
2653         return;
2654     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2655         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2656             GV *gv = MUTABLE_GV(HeVAL(entry));
2657             HV *hv;
2658             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2659                 continue;
2660             if (GvCVu(gv))
2661                 xmldump_sub_perl(gv, justperl);
2662             if (GvFORM(gv))
2663                 xmldump_form(gv);
2664             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2665                 && (hv = GvHV(gv)) && hv != PL_defstash)
2666                 xmldump_packsubs_perl(hv, justperl);    /* nested package */
2667         }
2668     }
2669 }
2670
2671 void
2672 Perl_xmldump_sub(pTHX_ const GV *gv)
2673 {
2674     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2675     xmldump_sub_perl(gv, FALSE);
2676 }
2677
2678 void
2679 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2680 {
2681     SV * sv;
2682
2683     PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2684
2685     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2686         return;
2687
2688     sv = sv_newmortal();
2689     gv_fullname3(sv, gv, NULL);
2690     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2691     if (CvXSUB(GvCV(gv)))
2692         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2693             PTR2UV(CvXSUB(GvCV(gv))),
2694             (int)CvXSUBANY(GvCV(gv)).any_i32);
2695     else if (CvROOT(GvCV(gv)))
2696         op_xmldump(CvROOT(GvCV(gv)));
2697     else
2698         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2699 }
2700
2701 void
2702 Perl_xmldump_form(pTHX_ const GV *gv)
2703 {
2704     SV * const sv = sv_newmortal();
2705
2706     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2707
2708     gv_fullname3(sv, gv, NULL);
2709     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2710     if (CvROOT(GvFORM(gv)))
2711         op_xmldump(CvROOT(GvFORM(gv)));
2712     else
2713         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2714 }
2715
2716 void
2717 Perl_xmldump_eval(pTHX)
2718 {
2719     op_xmldump(PL_eval_root);
2720 }
2721
2722 char *
2723 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2724 {
2725     PERL_ARGS_ASSERT_SV_CATXMLSV;
2726     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2727 }
2728
2729 char *
2730 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2731 {
2732     PERL_ARGS_ASSERT_SV_CATXMLPV;
2733     return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2734 }
2735
2736 char *
2737 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2738 {
2739     unsigned int c;
2740     const char * const e = pv + len;
2741     const char * const start = pv;
2742     STRLEN dsvcur;
2743     STRLEN cl;
2744
2745     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2746
2747     sv_catpvs(dsv,"");
2748     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2749
2750   retry:
2751     while (pv < e) {
2752         if (utf8) {
2753             c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
2754             if (cl == 0) {
2755                 SvCUR(dsv) = dsvcur;
2756                 pv = start;
2757                 utf8 = 0;
2758                 goto retry;
2759             }
2760         }
2761         else
2762             c = (*pv & 255);
2763
2764         if (isCNTRL_L1(c)
2765             && c != '\t'
2766             && c != '\n'
2767             && c != '\r'
2768             && c != LATIN1_TO_NATIVE(0x85))
2769         {
2770             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2771         }
2772         else switch (c) {
2773         case '<':
2774             sv_catpvs(dsv, "&lt;");
2775             break;
2776         case '>':
2777             sv_catpvs(dsv, "&gt;");
2778             break;
2779         case '&':
2780             sv_catpvs(dsv, "&amp;");
2781             break;
2782         case '"':
2783             sv_catpvs(dsv, "&#34;");
2784             break;
2785         default:
2786             if (c < 0xD800) {
2787                 if (! isPRINT(c)) {
2788                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2789                 }
2790                 else {
2791                     const char string = (char) c;
2792                     sv_catpvn(dsv, &string, 1);
2793                 }
2794                 break;
2795             }
2796             if ((c >= 0xD800 && c <= 0xDB7F) ||
2797                 (c >= 0xDC00 && c <= 0xDFFF) ||
2798                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2799                  c > 0x10ffff)
2800                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2801             else
2802                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2803         }
2804
2805         if (utf8)
2806             pv += UTF8SKIP(pv);
2807         else
2808             pv++;
2809     }
2810
2811     return SvPVX(dsv);
2812 }
2813
2814 char *
2815 Perl_sv_xmlpeek(pTHX_ SV *sv)
2816 {
2817     SV * const t = sv_newmortal();
2818     STRLEN n_a;
2819     int unref = 0;
2820
2821     PERL_ARGS_ASSERT_SV_XMLPEEK;
2822
2823     sv_utf8_upgrade(t);
2824     sv_setpvs(t, "");
2825     /* retry: */
2826     if (!sv) {
2827         sv_catpv(t, "VOID=\"\"");
2828         goto finish;
2829     }
2830     else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
2831         sv_catpv(t, "WILD=\"\"");
2832         goto finish;
2833     }
2834     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2835         if (sv == &PL_sv_undef) {
2836             sv_catpv(t, "SV_UNDEF=\"1\"");
2837             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2838                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2839                 SvREADONLY(sv))
2840                 goto finish;
2841         }
2842         else if (sv == &PL_sv_no) {
2843             sv_catpv(t, "SV_NO=\"1\"");
2844             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2845                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2846                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2847                                   SVp_POK|SVp_NOK)) &&
2848                 SvCUR(sv) == 0 &&
2849                 SvNVX(sv) == 0.0)
2850                 goto finish;
2851         }
2852         else if (sv == &PL_sv_yes) {
2853             sv_catpv(t, "SV_YES=\"1\"");
2854             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2855                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2856                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2857                                   SVp_POK|SVp_NOK)) &&
2858                 SvCUR(sv) == 1 &&
2859                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2860                 SvNVX(sv) == 1.0)
2861                 goto finish;
2862         }
2863         else {
2864             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2865             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2866                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2867                 SvREADONLY(sv))
2868                 goto finish;
2869         }
2870         sv_catpv(t, " XXX=\"\" ");
2871     }
2872     else if (SvREFCNT(sv) == 0) {
2873         sv_catpv(t, " refcnt=\"0\"");
2874         unref++;
2875     }
2876     else if (DEBUG_R_TEST_) {
2877         int is_tmp = 0;
2878         SSize_t ix;
2879         /* is this SV on the tmps stack? */
2880         for (ix=PL_tmps_ix; ix>=0; ix--) {
2881             if (PL_tmps_stack[ix] == sv) {
2882                 is_tmp = 1;
2883                 break;
2884             }
2885         }
2886         if (SvREFCNT(sv) > 1)
2887             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2888                     is_tmp ? "T" : "");
2889         else if (is_tmp)
2890             sv_catpv(t, " DRT=\"<T>\"");
2891     }
2892
2893     if (SvROK(sv)) {
2894         sv_catpv(t, " ROK=\"\"");
2895     }
2896     switch (SvTYPE(sv)) {
2897     default:
2898         sv_catpv(t, " FREED=\"1\"");
2899         goto finish;
2900
2901     case SVt_NULL:
2902         sv_catpv(t, " UNDEF=\"1\"");
2903         goto finish;
2904     case SVt_IV:
2905         sv_catpv(t, " IV=\"");
2906         break;
2907     case SVt_NV:
2908         sv_catpv(t, " NV=\"");
2909         break;
2910     case SVt_PV:
2911         sv_catpv(t, " PV=\"");
2912         break;
2913     case SVt_PVIV:
2914         sv_catpv(t, " PVIV=\"");
2915         break;
2916     case SVt_PVNV:
2917         sv_catpv(t, " PVNV=\"");
2918         break;
2919     case SVt_PVMG:
2920         sv_catpv(t, " PVMG=\"");
2921         break;
2922     case SVt_PVLV:
2923         sv_catpv(t, " PVLV=\"");
2924         break;
2925     case SVt_PVAV:
2926         sv_catpv(t, " AV=\"");
2927         break;
2928     case SVt_PVHV:
2929         sv_catpv(t, " HV=\"");
2930         break;
2931     case SVt_PVCV:
2932         if (CvGV(sv))
2933             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2934         else
2935             sv_catpv(t, " CV=\"()\"");
2936         goto finish;
2937     case SVt_PVGV:
2938         sv_catpv(t, " GV=\"");
2939         break;
2940     case SVt_INVLIST:
2941         sv_catpv(t, " DUMMY=\"");
2942         break;
2943     case SVt_REGEXP:
2944         sv_catpv(t, " REGEXP=\"");
2945         break;
2946     case SVt_PVFM:
2947         sv_catpv(t, " FM=\"");
2948         break;
2949     case SVt_PVIO:
2950         sv_catpv(t, " IO=\"");
2951         break;
2952     }
2953
2954     if (SvPOKp(sv)) {
2955         if (SvPVX(sv)) {
2956             sv_catxmlsv(t, sv);
2957         }
2958     }
2959     else if (SvNOKp(sv)) {
2960         STORE_NUMERIC_LOCAL_SET_STANDARD();
2961         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2962         RESTORE_NUMERIC_LOCAL();
2963     }
2964     else if (SvIOKp(sv)) {
2965         if (SvIsUV(sv))
2966             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2967         else
2968             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2969     }
2970     else
2971         sv_catpv(t, "");
2972     sv_catpv(t, "\"");
2973
2974   finish:
2975     while (unref--)
2976         sv_catpv(t, ")");
2977     return SvPV(t, n_a);
2978 }
2979
2980 void
2981 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2982 {
2983     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2984
2985     if (!pm) {
2986         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2987         return;
2988     }
2989     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2990     level++;
2991     if (PM_GETRE(pm)) {
2992         REGEXP *const r = PM_GETRE(pm);
2993         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2994         sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2995         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2996              SvPVX(tmpsv));
2997         SvREFCNT_dec_NN(tmpsv);
2998         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2999              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
3000     }
3001     else
3002         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
3003     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
3004         SV * const tmpsv = pm_description(pm);
3005         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
3006         SvREFCNT_dec_NN(tmpsv);
3007     }
3008
3009     level--;
3010     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
3011         Perl_xmldump_indent(aTHX_ level, file, ">\n");
3012         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
3013         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
3014         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
3015         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
3016     }
3017     else
3018         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
3019 }
3020
3021 void
3022 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
3023 {
3024     do_pmop_xmldump(0, PL_xmlfp, pm);
3025 }
3026
3027 void
3028 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
3029 {
3030     UV      seq;
3031     int     contents = 0;
3032     const OPCODE optype = o->op_type;
3033
3034     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
3035
3036     if (!o)
3037         return;
3038     seq = sequence_num(o);
3039     Perl_xmldump_indent(aTHX_ level, file,
3040         "<op_%s seq=\"%"UVuf" -> ",
3041              OP_NAME(o),
3042                       seq);
3043     level++;
3044     if (o->op_next)
3045         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
3046                       sequence_num(o->op_next));
3047     else
3048         PerlIO_printf(file, "DONE\"");
3049
3050     if (o->op_targ) {
3051         if (optype == OP_NULL)
3052         {
3053             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
3054             if (o->op_targ == OP_NEXTSTATE)
3055             {
3056                 if (CopLINE(cCOPo))
3057                     PerlIO_printf(file, " line=\"%"UVuf"\"",
3058                                      (UV)CopLINE(cCOPo));
3059                 if (CopSTASHPV(cCOPo))
3060                     PerlIO_printf(file, " package=\"%s\"",
3061                                      CopSTASHPV(cCOPo));
3062                 if (CopLABEL(cCOPo))
3063                     PerlIO_printf(file, " label=\"%s\"",
3064                                      CopLABEL(cCOPo));
3065             }
3066         }
3067         else
3068             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
3069     }
3070 #ifdef DUMPADDR
3071     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
3072 #endif
3073
3074     DUMP_OP_FLAGS(o,1,0,file);
3075     DUMP_OP_PRIVATE(o,1,0,file);
3076
3077     switch (optype) {
3078     case OP_AELEMFAST:
3079         if (o->op_flags & OPf_SPECIAL) {
3080             break;
3081         }
3082     case OP_GVSV:
3083     case OP_GV:
3084 #ifdef USE_ITHREADS
3085         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3086 #else
3087         if (cSVOPo->op_sv) {
3088             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3089             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3090             char *s;
3091             STRLEN len;
3092             ENTER;
3093             SAVEFREESV(tmpsv1);
3094             SAVEFREESV(tmpsv2);
3095             gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3096             s = SvPV(tmpsv1,len);
3097             sv_catxmlpvn(tmpsv2, s, len, 1);
3098             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3099             LEAVE;
3100         }
3101         else
3102             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3103 #endif
3104         break;
3105     case OP_CONST:
3106     case OP_HINTSEVAL:
3107     case OP_METHOD_NAMED:
3108 #ifndef USE_ITHREADS
3109         /* with ITHREADS, consts are stored in the pad, and the right pad
3110          * may not be active here, so skip */
3111         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3112 #endif
3113         break;
3114     case OP_ANONCODE:
3115         if (!contents) {
3116             contents = 1;
3117             PerlIO_printf(file, ">\n");
3118         }
3119         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3120         break;
3121     case OP_NEXTSTATE:
3122     case OP_DBSTATE:
3123         if (CopLINE(cCOPo))
3124             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3125                              (UV)CopLINE(cCOPo));
3126         if (CopSTASHPV(cCOPo))
3127             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3128                              CopSTASHPV(cCOPo));
3129         if (CopLABEL(cCOPo))
3130             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3131                              CopLABEL(cCOPo));
3132         break;
3133     case OP_ENTERLOOP:
3134         S_xmldump_attr(aTHX_ level, file, "redo=\"");
3135         if (cLOOPo->op_redoop)
3136             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3137         else
3138             PerlIO_printf(file, "DONE\"");
3139         S_xmldump_attr(aTHX_ level, file, "next=\"");
3140         if (cLOOPo->op_nextop)
3141             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3142         else
3143             PerlIO_printf(file, "DONE\"");
3144         S_xmldump_attr(aTHX_ level, file, "last=\"");
3145         if (cLOOPo->op_lastop)
3146             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3147         else
3148             PerlIO_printf(file, "DONE\"");
3149         break;
3150     case OP_COND_EXPR:
3151     case OP_RANGE:
3152     case OP_MAPWHILE:
3153     case OP_GREPWHILE:
3154     case OP_OR:
3155     case OP_AND:
3156         S_xmldump_attr(aTHX_ level, file, "other=\"");
3157         if (cLOGOPo->op_other)
3158             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3159         else
3160             PerlIO_printf(file, "DONE\"");
3161         break;
3162     case OP_LEAVE:
3163     case OP_LEAVEEVAL:
3164     case OP_LEAVESUB:
3165     case OP_LEAVESUBLV:
3166     case OP_LEAVEWRITE:
3167     case OP_SCOPE:
3168         if (o->op_private & OPpREFCOUNTED)
3169             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3170         break;
3171     default:
3172         break;
3173     }
3174
3175     if (PL_madskills && o->op_madprop) {
3176         char prevkey = '\0';
3177         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3178         const MADPROP* mp = o->op_madprop;
3179
3180         if (!contents) {
3181             contents = 1;
3182             PerlIO_printf(file, ">\n");
3183         }
3184         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3185         level++;
3186         while (mp) {
3187             char tmp = mp->mad_key;
3188             sv_setpvs(tmpsv,"\"");
3189             if (tmp)
3190                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3191             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3192                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3193             else
3194                 prevkey = tmp;
3195             sv_catpv(tmpsv, "\"");
3196             switch (mp->mad_type) {
3197             case MAD_NULL:
3198                 sv_catpv(tmpsv, "NULL");
3199                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3200                 break;
3201             case MAD_PV:
3202                 sv_catpv(tmpsv, " val=\"");
3203                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3204                 sv_catpv(tmpsv, "\"");
3205                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3206                 break;
3207             case MAD_SV:
3208                 sv_catpv(tmpsv, " val=\"");
3209                 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3210                 sv_catpv(tmpsv, "\"");
3211                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3212                 break;
3213             case MAD_OP:
3214                 if ((OP*)mp->mad_val) {
3215                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3216                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3217                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3218                 }
3219                 break;
3220             default:
3221                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3222                 break;
3223             }
3224             mp = mp->mad_next;
3225         }
3226         level--;
3227         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3228
3229         SvREFCNT_dec_NN(tmpsv);
3230     }
3231
3232     switch (optype) {
3233     case OP_PUSHRE:
3234     case OP_MATCH:
3235     case OP_QR:
3236     case OP_SUBST:
3237         if (!contents) {
3238             contents = 1;
3239             PerlIO_printf(file, ">\n");
3240         }
3241         do_pmop_xmldump(level, file, cPMOPo);
3242         break;
3243     default:
3244         break;
3245     }
3246
3247     if (o->op_flags & OPf_KIDS) {
3248         OP *kid;
3249         if (!contents) {
3250             contents = 1;
3251             PerlIO_printf(file, ">\n");
3252         }
3253         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3254             do_op_xmldump(level, file, kid);
3255     }
3256
3257     if (contents)
3258         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3259     else
3260         PerlIO_printf(file, " />\n");
3261 }
3262
3263 void
3264 Perl_op_xmldump(pTHX_ const OP *o)
3265 {
3266     PERL_ARGS_ASSERT_OP_XMLDUMP;
3267
3268     do_op_xmldump(0, PL_xmlfp, o);
3269 }
3270 #endif
3271
3272 /*
3273  * Local variables:
3274  * c-indentation-style: bsd
3275  * c-basic-offset: 4
3276  * indent-tabs-mode: nil
3277  * End:
3278  *
3279  * ex: set ts=8 sts=4 sw=4 et:
3280  */