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