dump.c

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