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 =head1 Display and Dump functions
  25  */
  26
  27 #include "EXTERN.h"
  28 #define PERL_IN_DUMP_C
  29 #include "perl.h"
  30 #include "regcomp.h"
  31
  32 static const char* const svtypenames[SVt_LAST] = {
  33     "NULL",
  34     "IV",
  35     "NV",
  36     "PV",
  37     "INVLIST",
  38     "PVIV",
  39     "PVNV",
  40     "PVMG",
  41     "REGEXP",
  42     "PVGV",
  43     "PVLV",
  44     "PVAV",
  45     "PVHV",
  46     "PVCV",
  47     "PVFM",
  48     "PVIO"
  49 };
  50
  51
  52 static const char* const svshorttypenames[SVt_LAST] = {
  53     "UNDEF",
  54     "IV",
  55     "NV",
  56     "PV",
  57     "INVLST",
  58     "PVIV",
  59     "PVNV",
  60     "PVMG",
  61     "REGEXP",
  62     "GV",
  63     "PVLV",
  64     "AV",
  65     "HV",
  66     "CV",
  67     "FM",
  68     "IO"
  69 };
  70
  71 struct flag_to_name {
  72     U32 flag;
  73     const char *name;
  74 };
  75
  76 static void
  77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
  78                const struct flag_to_name *const end)
  79 {
  80     do {
  81         if (flags & start->flag)
  82             sv_catpv(sv, start->name);
  83     } while (++start < end);
  84 }
  85
  86 #define append_flags(sv, f, flags) \
  87     S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
  88
  89 #define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
  90                               (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
  91                               PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
  92                               | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
  93
  94 /*
  95 =for apidoc pv_escape
  96
  97 Escapes at most the first C<count> chars of C<pv> and puts the results into
  98 C<dsv> such that the size of the escaped string will not exceed C<max> chars
  99 and will not contain any incomplete escape sequences.  The number of bytes
 100 escaped will be returned in the C<STRLEN *escaped> parameter if it is not null.
 101 When the C<dsv> parameter is null no escaping actually occurs, but the number
 102 of bytes that would be escaped were it not null will be calculated.
 103
 104 If flags contains C<PERL_PV_ESCAPE_QUOTE> then any double quotes in the string
 105 will also be escaped.
 106
 107 Normally the SV will be cleared before the escaped string is prepared,
 108 but when C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur.
 109
 110 If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8
 111 if C<PERL_PV_ESCAPE_UNI_DETECT> is set then the input string is scanned
 112 using C<is_utf8_string()> to determine if it is UTF-8.
 113
 114 If C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output
 115 using C<\x01F1> style escapes, otherwise if C<PERL_PV_ESCAPE_NONASCII> is set, only
 116 non-ASCII chars will be escaped using this style; otherwise, only chars above
 117 255 will be so escaped; other non printable chars will use octal or
 118 common escaped patterns like C<\n>.
 119 Otherwise, if C<PERL_PV_ESCAPE_NOBACKSLASH>
 120 then all chars below 255 will be treated as printable and
 121 will be output as literals.
 122
 123 If C<PERL_PV_ESCAPE_FIRSTCHAR> is set then only the first char of the
 124 string will be escaped, regardless of max.  If the output is to be in hex,
 125 then it will be returned as a plain hex
 126 sequence.  Thus the output will either be a single char,
 127 an octal escape sequence, a special escape like C<\n> or a hex value.
 128
 129 If C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a C<"%"> and
 130 not a C<"\\">.  This is because regexes very often contain backslashed
 131 sequences, whereas C<"%"> is not a particularly common character in patterns.
 132
 133 Returns a pointer to the escaped text as held by C<dsv>.
 134
 135 =cut
 136 */
 137 #define PV_ESCAPE_OCTBUFSIZE 32
 138
 139 char *
 140 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
 141                 const STRLEN count, const STRLEN max,
 142                 STRLEN * const escaped, const U32 flags )
 143 {
 144     const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
 145     const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
 146     char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
 147     STRLEN wrote = 0;    /* chars written so far */
 148     STRLEN chsize = 0;   /* size of data to be written */
 149     STRLEN readsize = 1; /* size of data just read */
 150     bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this UTF-8 */
 151     const char *pv  = str;
 152     const char * const end = pv + count; /* end of string */
 153     octbuf[0] = esc;
 154
 155     PERL_ARGS_ASSERT_PV_ESCAPE;
 156
 157     if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
 158             /* This won't alter the UTF-8 flag */
 159             sv_setpvs(dsv, "");
 160     }
 161
 162     if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
 163         isuni = 1;
 164
 165     for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
 166         const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
 167         const U8 c = (U8)u & 0xFF;
 168
 169         if ( ( u > 255 )
 170           || (flags & PERL_PV_ESCAPE_ALL)
 171           || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
 172         {
 173             if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
 174                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 175                                       "%"UVxf, u);
 176             else
 177                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 178                                       ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
 179                                       ? "%cx%02"UVxf
 180                                       : "%cx{%02"UVxf"}", esc, u);
 181
 182         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
 183             chsize = 1;
 184         } else {
 185             if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
 186                 chsize = 2;
 187                 switch (c) {
 188
 189                 case '\\' : /* FALLTHROUGH */
 190                 case '%'  : if ( c == esc )  {
 191                                 octbuf[1] = esc;
 192                             } else {
 193                                 chsize = 1;
 194                             }
 195                             break;
 196                 case '\v' : octbuf[1] = 'v';  break;
 197                 case '\t' : octbuf[1] = 't';  break;
 198                 case '\r' : octbuf[1] = 'r';  break;
 199                 case '\n' : octbuf[1] = 'n';  break;
 200                 case '\f' : octbuf[1] = 'f';  break;
 201                 case '"'  :
 202                         if ( dq == '"' )
 203                                 octbuf[1] = '"';
 204                         else
 205                             chsize = 1;
 206                         break;
 207                 default:
 208                      if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
 209                         chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 210                                       isuni ? "%cx{%02"UVxf"}" : "%cx%02"UVxf,
 211                                       esc, u);
 212                      }
 213                      else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
 214                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 215                                                   "%c%03o", esc, c);
 216                         else
 217                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 218                                                   "%c%o", esc, c);
 219                 }
 220             } else {
 221                 chsize = 1;
 222             }
 223         }
 224         if ( max && (wrote + chsize > max) ) {
 225             break;
 226         } else if (chsize > 1) {
 227             if (dsv)
 228                 sv_catpvn(dsv, octbuf, chsize);
 229             wrote += chsize;
 230         } else {
 231             /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
 232                can be appended raw to the dsv. If dsv happens to be
 233                UTF-8 then we need catpvf to upgrade them for us.
 234                Or add a new API call sv_catpvc(). Think about that name, and
 235                how to keep it clear that it's unlike the s of catpvs, which is
 236                really an array of octets, not a string.  */
 237             if (dsv)
 238                 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
 239             wrote++;
 240         }
 241         if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
 242             break;
 243     }
 244     if (escaped != NULL)
 245         *escaped= pv - str;
 246     return dsv ? SvPVX(dsv) : NULL;
 247 }
 248 /*
 249 =for apidoc pv_pretty
 250
 251 Converts a string into something presentable, handling escaping via
 252 C<pv_escape()> and supporting quoting and ellipses.
 253
 254 If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be
 255 double quoted with any double quotes in the string escaped.  Otherwise
 256 if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
 257 angle brackets.
 258
 259 If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in
 260 string were output then an ellipsis C<...> will be appended to the
 261 string.  Note that this happens AFTER it has been quoted.
 262
 263 If C<start_color> is non-null then it will be inserted after the opening
 264 quote (if there is one) but before the escaped text.  If C<end_color>
 265 is non-null then it will be inserted after the escaped text but before
 266 any quotes or ellipses.
 267
 268 Returns a pointer to the prettified text as held by C<dsv>.
 269
 270 =cut
 271 */
 272
 273 char *
 274 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
 275   const STRLEN max, char const * const start_color, char const * const end_color,
 276   const U32 flags )
 277 {
 278     const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
 279                              (flags & PERL_PV_PRETTY_LTGT)  ? "<>" : NULL);
 280     STRLEN escaped;
 281     STRLEN max_adjust= 0;
 282     STRLEN orig_cur;
 283
 284     PERL_ARGS_ASSERT_PV_PRETTY;
 285
 286     if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
 287         /* This won't alter the UTF-8 flag */
 288         sv_setpvs(dsv, "");
 289     }
 290     orig_cur= SvCUR(dsv);
 291
 292     if ( quotes )
 293         Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
 294
 295     if ( start_color != NULL )
 296         sv_catpv(dsv, start_color);
 297
 298     if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
 299         if (quotes)
 300             max_adjust += 2;
 301         assert(max > max_adjust);
 302         pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
 303         if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
 304             max_adjust += 3;
 305         assert(max > max_adjust);
 306     }
 307
 308     pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
 309
 310     if ( end_color != NULL )
 311         sv_catpv(dsv, end_color);
 312
 313     if ( quotes )
 314         Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
 315
 316     if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
 317             sv_catpvs(dsv, "...");
 318
 319     if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
 320         while( SvCUR(dsv) - orig_cur < max )
 321             sv_catpvs(dsv," ");
 322     }
 323
 324     return SvPVX(dsv);
 325 }
 326
 327 /*
 328 =for apidoc pv_display
 329
 330 Similar to
 331
 332   pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
 333
 334 except that an additional "\0" will be appended to the string when
 335 len > cur and pv[cur] is "\0".
 336
 337 Note that the final string may be up to 7 chars longer than pvlim.
 338
 339 =cut
 340 */
 341
 342 char *
 343 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
 344 {
 345     PERL_ARGS_ASSERT_PV_DISPLAY;
 346
 347     pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
 348     if (len > cur && pv[cur] == '\0')
 349             sv_catpvs( dsv, "\\0");
 350     return SvPVX(dsv);
 351 }
 352
 353 char *
 354 Perl_sv_peek(pTHX_ SV *sv)
 355 {
 356     dVAR;
 357     SV * const t = sv_newmortal();
 358     int unref = 0;
 359     U32 type;
 360
 361     sv_setpvs(t, "");
 362   retry:
 363     if (!sv) {
 364         sv_catpv(t, "VOID");
 365         goto finish;
 366     }
 367     else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
 368         /* detect data corruption under memory poisoning */
 369         sv_catpv(t, "WILD");
 370         goto finish;
 371     }
 372     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
 373         if (sv == &PL_sv_undef) {
 374             sv_catpv(t, "SV_UNDEF");
 375             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 376                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 377                 SvREADONLY(sv))
 378                 goto finish;
 379         }
 380         else if (sv == &PL_sv_no) {
 381             sv_catpv(t, "SV_NO");
 382             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 383                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 384                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 385                                   SVp_POK|SVp_NOK)) &&
 386                 SvCUR(sv) == 0 &&
 387                 SvNVX(sv) == 0.0)
 388                 goto finish;
 389         }
 390         else if (sv == &PL_sv_yes) {
 391             sv_catpv(t, "SV_YES");
 392             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 393                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 394                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 395                                   SVp_POK|SVp_NOK)) &&
 396                 SvCUR(sv) == 1 &&
 397                 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
 398                 SvNVX(sv) == 1.0)
 399                 goto finish;
 400         }
 401         else {
 402             sv_catpv(t, "SV_PLACEHOLDER");
 403             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 404                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 405                 SvREADONLY(sv))
 406                 goto finish;
 407         }
 408         sv_catpv(t, ":");
 409     }
 410     else if (SvREFCNT(sv) == 0) {
 411         sv_catpv(t, "(");
 412         unref++;
 413     }
 414     else if (DEBUG_R_TEST_) {
 415         int is_tmp = 0;
 416         SSize_t ix;
 417         /* is this SV on the tmps stack? */
 418         for (ix=PL_tmps_ix; ix>=0; ix--) {
 419             if (PL_tmps_stack[ix] == sv) {
 420                 is_tmp = 1;
 421                 break;
 422             }
 423         }
 424         if (SvREFCNT(sv) > 1)
 425             Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
 426                     is_tmp ? "T" : "");
 427         else if (is_tmp)
 428             sv_catpv(t, "<T>");
 429     }
 430
 431     if (SvROK(sv)) {
 432         sv_catpv(t, "\\");
 433         if (SvCUR(t) + unref > 10) {
 434             SvCUR_set(t, unref + 3);
 435             *SvEND(t) = '\0';
 436             sv_catpv(t, "...");
 437             goto finish;
 438         }
 439         sv = SvRV(sv);
 440         goto retry;
 441     }
 442     type = SvTYPE(sv);
 443     if (type == SVt_PVCV) {
 444         SV * const tmp = newSVpvs_flags("", SVs_TEMP);
 445         GV* gvcv = CvGV(sv);
 446         Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
 447                        ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
 448                        : "");
 449         goto finish;
 450     } else if (type < SVt_LAST) {
 451         sv_catpv(t, svshorttypenames[type]);
 452
 453         if (type == SVt_NULL)
 454             goto finish;
 455     } else {
 456         sv_catpv(t, "FREED");
 457         goto finish;
 458     }
 459
 460     if (SvPOKp(sv)) {
 461         if (!SvPVX_const(sv))
 462             sv_catpv(t, "(null)");
 463         else {
 464             SV * const tmp = newSVpvs("");
 465             sv_catpv(t, "(");
 466             if (SvOOK(sv)) {
 467                 STRLEN delta;
 468                 SvOOK_offset(sv, delta);
 469                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
 470             }
 471             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
 472             if (SvUTF8(sv))
 473                 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
 474                                sv_uni_display(tmp, sv, 6 * SvCUR(sv),
 475                                               UNI_DISPLAY_QQ));
 476             SvREFCNT_dec_NN(tmp);
 477         }
 478     }
 479     else if (SvNOKp(sv)) {
 480         STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
 481         Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
 482         RESTORE_LC_NUMERIC_UNDERLYING();
 483     }
 484     else if (SvIOKp(sv)) {
 485         if (SvIsUV(sv))
 486             Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
 487         else
 488             Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
 489     }
 490     else
 491         sv_catpv(t, "()");
 492
 493   finish:
 494     while (unref--)
 495         sv_catpv(t, ")");
 496     if (TAINTING_get && sv && SvTAINTED(sv))
 497         sv_catpv(t, " [tainted]");
 498     return SvPV_nolen(t);
 499 }
 500
 501 /*
 502 =head1 Debugging Utilities
 503 */
 504
 505 void
 506 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
 507 {
 508     va_list args;
 509     PERL_ARGS_ASSERT_DUMP_INDENT;
 510     va_start(args, pat);
 511     dump_vindent(level, file, pat, &args);
 512     va_end(args);
 513 }
 514
 515 void
 516 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
 517 {
 518     PERL_ARGS_ASSERT_DUMP_VINDENT;
 519     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
 520     PerlIO_vprintf(file, pat, *args);
 521 }
 522
 523 /*
 524 =for apidoc dump_all
 525
 526 Dumps the entire optree of the current program starting at C<PL_main_root> to
 527 C<STDERR>.  Also dumps the optrees for all visible subroutines in
 528 C<PL_defstash>.
 529
 530 =cut
 531 */
 532
 533 void
 534 Perl_dump_all(pTHX)
 535 {
 536     dump_all_perl(FALSE);
 537 }
 538
 539 void
 540 Perl_dump_all_perl(pTHX_ bool justperl)
 541 {
 542     PerlIO_setlinebuf(Perl_debug_log);
 543     if (PL_main_root)
 544         op_dump(PL_main_root);
 545     dump_packsubs_perl(PL_defstash, justperl);
 546 }
 547
 548 /*
 549 =for apidoc dump_packsubs
 550
 551 Dumps the optrees for all visible subroutines in C<stash>.
 552
 553 =cut
 554 */
 555
 556 void
 557 Perl_dump_packsubs(pTHX_ const HV *stash)
 558 {
 559     PERL_ARGS_ASSERT_DUMP_PACKSUBS;
 560     dump_packsubs_perl(stash, FALSE);
 561 }
 562
 563 void
 564 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
 565 {
 566     I32 i;
 567
 568     PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
 569
 570     if (!HvARRAY(stash))
 571         return;
 572     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 573         const HE *entry;
 574         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 575             GV * gv = (GV *)HeVAL(entry);
 576             if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
 577                 /* unfake a fake GV */
 578                 (void)CvGV(SvRV(gv));
 579             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 580                 continue;
 581             if (GvCVu(gv))
 582                 dump_sub_perl(gv, justperl);
 583             if (GvFORM(gv))
 584                 dump_form(gv);
 585             if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
 586                 const HV * const hv = GvHV(gv);
 587                 if (hv && (hv != PL_defstash))
 588                     dump_packsubs_perl(hv, justperl); /* nested package */
 589             }
 590         }
 591     }
 592 }
 593
 594 void
 595 Perl_dump_sub(pTHX_ const GV *gv)
 596 {
 597     PERL_ARGS_ASSERT_DUMP_SUB;
 598     dump_sub_perl(gv, FALSE);
 599 }
 600
 601 void
 602 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
 603 {
 604     STRLEN len;
 605     SV * const sv = newSVpvs_flags("", SVs_TEMP);
 606     SV *tmpsv;
 607     const char * name;
 608
 609     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
 610
 611     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
 612         return;
 613
 614     tmpsv = newSVpvs_flags("", SVs_TEMP);
 615     gv_fullname3(sv, gv, NULL);
 616     name = SvPV_const(sv, len);
 617     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
 618                      generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
 619     if (CvISXSUB(GvCV(gv)))
 620         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
 621             PTR2UV(CvXSUB(GvCV(gv))),
 622             (int)CvXSUBANY(GvCV(gv)).any_i32);
 623     else if (CvROOT(GvCV(gv)))
 624         op_dump(CvROOT(GvCV(gv)));
 625     else
 626         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 627 }
 628
 629 void
 630 Perl_dump_form(pTHX_ const GV *gv)
 631 {
 632     SV * const sv = sv_newmortal();
 633
 634     PERL_ARGS_ASSERT_DUMP_FORM;
 635
 636     gv_fullname3(sv, gv, NULL);
 637     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
 638     if (CvROOT(GvFORM(gv)))
 639         op_dump(CvROOT(GvFORM(gv)));
 640     else
 641         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 642 }
 643
 644 void
 645 Perl_dump_eval(pTHX)
 646 {
 647     op_dump(PL_eval_root);
 648 }
 649
 650 void
 651 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
 652 {
 653     char ch;
 654
 655     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
 656
 657     if (!pm) {
 658         Perl_dump_indent(aTHX_ level, file, "{}\n");
 659         return;
 660     }
 661     Perl_dump_indent(aTHX_ level, file, "{\n");
 662     level++;
 663     if (pm->op_pmflags & PMf_ONCE)
 664         ch = '?';
 665     else
 666         ch = '/';
 667     if (PM_GETRE(pm))
 668         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n",
 669              ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch,
 670              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
 671     else
 672         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
 673     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
 674         Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
 675         op_dump(pm->op_pmreplrootu.op_pmreplroot);
 676     }
 677     if (pm->op_code_list) {
 678         if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
 679             Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
 680             do_op_dump(level, file, pm->op_code_list);
 681         }
 682         else
 683             Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
 684                                     PTR2UV(pm->op_code_list));
 685     }
 686     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
 687         SV * const tmpsv = pm_description(pm);
 688         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 689         SvREFCNT_dec_NN(tmpsv);
 690     }
 691
 692     Perl_dump_indent(aTHX_ level-1, file, "}\n");
 693 }
 694
 695 const struct flag_to_name pmflags_flags_names[] = {
 696     {PMf_CONST, ",CONST"},
 697     {PMf_KEEP, ",KEEP"},
 698     {PMf_GLOBAL, ",GLOBAL"},
 699     {PMf_CONTINUE, ",CONTINUE"},
 700     {PMf_RETAINT, ",RETAINT"},
 701     {PMf_EVAL, ",EVAL"},
 702     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
 703     {PMf_HAS_CV, ",HAS_CV"},
 704     {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
 705     {PMf_IS_QR, ",IS_QR"}
 706 };
 707
 708 static SV *
 709 S_pm_description(pTHX_ const PMOP *pm)
 710 {
 711     SV * const desc = newSVpvs("");
 712     const REGEXP * const regex = PM_GETRE(pm);
 713     const U32 pmflags = pm->op_pmflags;
 714
 715     PERL_ARGS_ASSERT_PM_DESCRIPTION;
 716
 717     if (pmflags & PMf_ONCE)
 718         sv_catpv(desc, ",ONCE");
 719 #ifdef USE_ITHREADS
 720     if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
 721         sv_catpv(desc, ":USED");
 722 #else
 723     if (pmflags & PMf_USED)
 724         sv_catpv(desc, ":USED");
 725 #endif
 726
 727     if (regex) {
 728         if (RX_ISTAINTED(regex))
 729             sv_catpv(desc, ",TAINTED");
 730         if (RX_CHECK_SUBSTR(regex)) {
 731             if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
 732                 sv_catpv(desc, ",SCANFIRST");
 733             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
 734                 sv_catpv(desc, ",ALL");
 735         }
 736         if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
 737             sv_catpv(desc, ",SKIPWHITE");
 738     }
 739
 740     append_flags(desc, pmflags, pmflags_flags_names);
 741     return desc;
 742 }
 743
 744 void
 745 Perl_pmop_dump(pTHX_ PMOP *pm)
 746 {
 747     do_pmop_dump(0, Perl_debug_log, pm);
 748 }
 749
 750 /* Return a unique integer to represent the address of op o.
 751  * If it already exists in PL_op_sequence, just return it;
 752  * otherwise add it.
 753  *  *** Note that this isn't thread-safe */
 754
 755 STATIC UV
 756 S_sequence_num(pTHX_ const OP *o)
 757 {
 758     dVAR;
 759     SV     *op,
 760           **seq;
 761     const char *key;
 762     STRLEN  len;
 763     if (!o)
 764         return 0;
 765     op = newSVuv(PTR2UV(o));
 766     sv_2mortal(op);
 767     key = SvPV_const(op, len);
 768     if (!PL_op_sequence)
 769         PL_op_sequence = newHV();
 770     seq = hv_fetch(PL_op_sequence, key, len, 0);
 771     if (seq)
 772         return SvUV(*seq);
 773     (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
 774     return PL_op_seq;
 775 }
 776
 777
 778
 779
 780
 781 const struct flag_to_name op_flags_names[] = {
 782     {OPf_KIDS, ",KIDS"},
 783     {OPf_PARENS, ",PARENS"},
 784     {OPf_REF, ",REF"},
 785     {OPf_MOD, ",MOD"},
 786     {OPf_STACKED, ",STACKED"},
 787     {OPf_SPECIAL, ",SPECIAL"}
 788 };
 789
 790
 791 void
 792 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 793 {
 794     UV      seq;
 795     const OPCODE optype = o->op_type;
 796
 797     PERL_ARGS_ASSERT_DO_OP_DUMP;
 798
 799     Perl_dump_indent(aTHX_ level, file, "{\n");
 800     level++;
 801     seq = sequence_num(o);
 802     if (seq)
 803         PerlIO_printf(file, "%-4"UVuf, seq);
 804     else
 805         PerlIO_printf(file, "????");
 806     PerlIO_printf(file,
 807                   "%*sTYPE = %s  ===> ",
 808                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
 809     if (o->op_next)
 810         PerlIO_printf(file,
 811                         o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
 812                                 sequence_num(o->op_next));
 813     else
 814         PerlIO_printf(file, "NULL\n");
 815     if (o->op_targ) {
 816         if (optype == OP_NULL) {
 817             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
 818         }
 819         else
 820             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
 821     }
 822 #ifdef DUMPADDR
 823     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
 824 #endif
 825
 826     if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
 827         SV * const tmpsv = newSVpvs("");
 828         switch (o->op_flags & OPf_WANT) {
 829         case OPf_WANT_VOID:
 830             sv_catpv(tmpsv, ",VOID");
 831             break;
 832         case OPf_WANT_SCALAR:
 833             sv_catpv(tmpsv, ",SCALAR");
 834             break;
 835         case OPf_WANT_LIST:
 836             sv_catpv(tmpsv, ",LIST");
 837             break;
 838         default:
 839             sv_catpv(tmpsv, ",UNKNOWN");
 840             break;
 841         }
 842         append_flags(tmpsv, o->op_flags, op_flags_names);
 843         if (o->op_slabbed)  sv_catpvs(tmpsv, ",SLABBED");
 844         if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
 845         if (o->op_static)   sv_catpvs(tmpsv, ",STATIC");
 846         if (o->op_folded)   sv_catpvs(tmpsv, ",FOLDED");
 847         if (o->op_moresib)  sv_catpvs(tmpsv, ",MORESIB");
 848         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
 849                          SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 850     }
 851
 852     if (o->op_private) {
 853         U16 oppriv = o->op_private;
 854         I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
 855         SV * tmpsv = NULL;
 856
 857         if (op_ix != -1) {
 858             U16 stop = 0;
 859             tmpsv = newSVpvs("");
 860             for (; !stop; op_ix++) {
 861                 U16 entry = PL_op_private_bitdefs[op_ix];
 862                 U16 bit = (entry >> 2) & 7;
 863                 U16 ix = entry >> 5;
 864
 865                 stop = (entry & 1);
 866
 867                 if (entry & 2) {
 868                     /* bitfield */
 869                     I16 const *p = &PL_op_private_bitfields[ix];
 870                     U16 bitmin = (U16) *p++;
 871                     I16 label = *p++;
 872                     I16 enum_label;
 873                     U16 mask = 0;
 874                     U16 i;
 875                     U16 val;
 876
 877                     for (i = bitmin; i<= bit; i++)
 878                         mask |= (1<<i);
 879                     bit = bitmin;
 880                     val = (oppriv & mask);
 881
 882                     if (   label != -1
 883                         && PL_op_private_labels[label] == '-'
 884                         && PL_op_private_labels[label+1] == '\0'
 885                     )
 886                         /* display as raw number */
 887                         continue;
 888
 889                     oppriv -= val;
 890                     val >>= bit;
 891                     enum_label = -1;
 892                     while (*p != -1) {
 893                         if (val == *p++) {
 894                             enum_label = *p;
 895                             break;
 896                         }
 897                         p++;
 898                     }
 899                     if (val == 0 && enum_label == -1)
 900                         /* don't display anonymous zero values */
 901                         continue;
 902
 903                     sv_catpv(tmpsv, ",");
 904                     if (label != -1) {
 905                         sv_catpv(tmpsv, &PL_op_private_labels[label]);
 906                         sv_catpv(tmpsv, "=");
 907                     }
 908                     if (enum_label == -1)
 909                         Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)val);
 910                     else
 911                         sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
 912
 913                 }
 914                 else {
 915                     /* bit flag */
 916                     if (   oppriv & (1<<bit)
 917                         && !(PL_op_private_labels[ix] == '-'
 918                              && PL_op_private_labels[ix+1] == '\0'))
 919                     {
 920                         oppriv -= (1<<bit);
 921                         sv_catpv(tmpsv, ",");
 922                         sv_catpv(tmpsv, &PL_op_private_labels[ix]);
 923                     }
 924                 }
 925             }
 926             if (oppriv) {
 927                 sv_catpv(tmpsv, ",");
 928                 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
 929             }
 930         }
 931         if (tmpsv && SvCUR(tmpsv)) {
 932             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
 933         } else
 934             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
 935                              (UV)oppriv);
 936     }
 937
 938     switch (optype) {
 939     case OP_AELEMFAST:
 940     case OP_GVSV:
 941     case OP_GV:
 942 #ifdef USE_ITHREADS
 943         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
 944 #else
 945         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
 946             if (cSVOPo->op_sv) {
 947       STRLEN len;
 948       const char * name;
 949       SV * const tmpsv  = newSVpvs_flags("", SVs_TEMP);
 950       SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
 951                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
 952       name = SvPV_const(tmpsv, len);
 953                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
 954                        generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
 955             }
 956             else
 957                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
 958         }
 959 #endif
 960         break;
 961
 962     case OP_MULTIDEREF:
 963     {
 964         UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
 965         UV i, count = items[-1].uv;
 966
 967         Perl_dump_indent(aTHX_ level, file, "ARGS = \n");
 968         for (i=0; i < count;  i++)
 969             Perl_dump_indent(aTHX_ level+1, file, "%"UVuf" => 0x%"UVxf"\n",
 970                                     i, items[i].uv);
 971     }
 972
 973     case OP_CONST:
 974     case OP_HINTSEVAL:
 975     case OP_METHOD_NAMED:
 976     case OP_METHOD_SUPER:
 977     case OP_METHOD_REDIR:
 978     case OP_METHOD_REDIR_SUPER:
 979 #ifndef USE_ITHREADS
 980         /* with ITHREADS, consts are stored in the pad, and the right pad
 981          * may not be active here, so skip */
 982         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
 983 #endif
 984         break;
 985     case OP_NULL:
 986         if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
 987             break;
 988         /* FALLTHROUGH */
 989     case OP_NEXTSTATE:
 990     case OP_DBSTATE:
 991         if (CopLINE(cCOPo))
 992             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
 993                              (UV)CopLINE(cCOPo));
 994     if (CopSTASHPV(cCOPo)) {
 995         SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
 996         HV *stash = CopSTASH(cCOPo);
 997         const char * const hvname = HvNAME_get(stash);
 998
 999             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1000                            generic_pv_escape(tmpsv, hvname,
1001                               HvNAMELEN(stash), HvNAMEUTF8(stash)));
1002     }
1003   if (CopLABEL(cCOPo)) {
1004        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1005        STRLEN label_len;
1006        U32 label_flags;
1007        const char *label = CopLABEL_len_flags(cCOPo,
1008                                                 &label_len, &label_flags);
1009        Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1010                            generic_pv_escape( tmpsv, label, label_len,
1011                                       (label_flags & SVf_UTF8)));
1012    }
1013         Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
1014                          (unsigned int)cCOPo->cop_seq);
1015         break;
1016     case OP_ENTERLOOP:
1017         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1018         if (cLOOPo->op_redoop)
1019             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1020         else
1021             PerlIO_printf(file, "DONE\n");
1022         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1023         if (cLOOPo->op_nextop)
1024             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1025         else
1026             PerlIO_printf(file, "DONE\n");
1027         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1028         if (cLOOPo->op_lastop)
1029             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1030         else
1031             PerlIO_printf(file, "DONE\n");
1032         break;
1033     case OP_COND_EXPR:
1034     case OP_RANGE:
1035     case OP_MAPWHILE:
1036     case OP_GREPWHILE:
1037     case OP_OR:
1038     case OP_AND:
1039         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1040         if (cLOGOPo->op_other)
1041             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1042         else
1043             PerlIO_printf(file, "DONE\n");
1044         break;
1045     case OP_PUSHRE:
1046     case OP_MATCH:
1047     case OP_QR:
1048     case OP_SUBST:
1049         do_pmop_dump(level, file, cPMOPo);
1050         break;
1051     case OP_LEAVE:
1052     case OP_LEAVEEVAL:
1053     case OP_LEAVESUB:
1054     case OP_LEAVESUBLV:
1055     case OP_LEAVEWRITE:
1056     case OP_SCOPE:
1057         if (o->op_private & OPpREFCOUNTED)
1058             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1059         break;
1060     default:
1061         break;
1062     }
1063     if (o->op_flags & OPf_KIDS) {
1064         OP *kid;
1065         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1066             do_op_dump(level, file, kid);
1067     }
1068     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1069 }
1070
1071 /*
1072 =for apidoc op_dump
1073
1074 Dumps the optree starting at OP C<o> to C<STDERR>.
1075
1076 =cut
1077 */
1078
1079 void
1080 Perl_op_dump(pTHX_ const OP *o)
1081 {
1082     PERL_ARGS_ASSERT_OP_DUMP;
1083     do_op_dump(0, Perl_debug_log, o);
1084 }
1085
1086 void
1087 Perl_gv_dump(pTHX_ GV *gv)
1088 {
1089     STRLEN len;
1090     const char* name;
1091     SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1092
1093     if (!gv) {
1094         PerlIO_printf(Perl_debug_log, "{}\n");
1095         return;
1096     }
1097     sv = sv_newmortal();
1098     PerlIO_printf(Perl_debug_log, "{\n");
1099     gv_fullname3(sv, gv, NULL);
1100     name = SvPV_const(sv, len);
1101     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1102                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1103     if (gv != GvEGV(gv)) {
1104         gv_efullname3(sv, GvEGV(gv), NULL);
1105         name = SvPV_const(sv, len);
1106         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1107                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1108     }
1109     (void)PerlIO_putc(Perl_debug_log, '\n');
1110     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1111 }
1112
1113
1114 /* map magic types to the symbolic names
1115  * (with the PERL_MAGIC_ prefixed stripped)
1116  */
1117
1118 static const struct { const char type; const char *name; } magic_names[] = {
1119 #include "mg_names.inc"
1120         /* this null string terminates the list */
1121         { 0,                         NULL },
1122 };
1123
1124 void
1125 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1126 {
1127     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1128
1129     for (; mg; mg = mg->mg_moremagic) {
1130         Perl_dump_indent(aTHX_ level, file,
1131                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1132         if (mg->mg_virtual) {
1133             const MGVTBL * const v = mg->mg_virtual;
1134             if (v >= PL_magic_vtables
1135                 && v < PL_magic_vtables + magic_vtable_max) {
1136                 const U32 i = v - PL_magic_vtables;
1137                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1138             }
1139             else
1140                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1141         }
1142         else
1143             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1144
1145         if (mg->mg_private)
1146             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1147
1148         {
1149             int n;
1150             const char *name = NULL;
1151             for (n = 0; magic_names[n].name; n++) {
1152                 if (mg->mg_type == magic_names[n].type) {
1153                     name = magic_names[n].name;
1154                     break;
1155                 }
1156             }
1157             if (name)
1158                 Perl_dump_indent(aTHX_ level, file,
1159                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1160             else
1161                 Perl_dump_indent(aTHX_ level, file,
1162                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1163         }
1164
1165         if (mg->mg_flags) {
1166             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1167             if (mg->mg_type == PERL_MAGIC_envelem &&
1168                 mg->mg_flags & MGf_TAINTEDDIR)
1169                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1170             if (mg->mg_type == PERL_MAGIC_regex_global &&
1171                 mg->mg_flags & MGf_MINMATCH)
1172                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1173             if (mg->mg_flags & MGf_REFCOUNTED)
1174                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1175             if (mg->mg_flags & MGf_GSKIP)
1176                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1177             if (mg->mg_flags & MGf_COPY)
1178                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1179             if (mg->mg_flags & MGf_DUP)
1180                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1181             if (mg->mg_flags & MGf_LOCAL)
1182                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1183             if (mg->mg_type == PERL_MAGIC_regex_global &&
1184                 mg->mg_flags & MGf_BYTES)
1185                 Perl_dump_indent(aTHX_ level, file, "      BYTES\n");
1186         }
1187         if (mg->mg_obj) {
1188             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1189                 PTR2UV(mg->mg_obj));
1190             if (mg->mg_type == PERL_MAGIC_qr) {
1191                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1192                 SV * const dsv = sv_newmortal();
1193                 const char * const s
1194                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1195                     60, NULL, NULL,
1196                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1197                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1198                 );
1199                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1200                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1201                         (IV)RX_REFCNT(re));
1202             }
1203             if (mg->mg_flags & MGf_REFCOUNTED)
1204                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1205         }
1206         if (mg->mg_len)
1207             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1208         if (mg->mg_ptr) {
1209             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1210             if (mg->mg_len >= 0) {
1211                 if (mg->mg_type != PERL_MAGIC_utf8) {
1212                     SV * const sv = newSVpvs("");
1213                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1214                     SvREFCNT_dec_NN(sv);
1215                 }
1216             }
1217             else if (mg->mg_len == HEf_SVKEY) {
1218                 PerlIO_puts(file, " => HEf_SVKEY\n");
1219                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1220                            maxnest, dumpops, pvlim); /* MG is already +1 */
1221                 continue;
1222             }
1223             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1224             else
1225                 PerlIO_puts(
1226                   file,
1227                  " ???? - " __FILE__
1228                  " does not know how to handle this MG_LEN"
1229                 );
1230             (void)PerlIO_putc(file, '\n');
1231         }
1232         if (mg->mg_type == PERL_MAGIC_utf8) {
1233             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1234             if (cache) {
1235                 IV i;
1236                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1237                     Perl_dump_indent(aTHX_ level, file,
1238                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1239                                      i,
1240                                      (UV)cache[i * 2],
1241                                      (UV)cache[i * 2 + 1]);
1242             }
1243         }
1244     }
1245 }
1246
1247 void
1248 Perl_magic_dump(pTHX_ const MAGIC *mg)
1249 {
1250     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1251 }
1252
1253 void
1254 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1255 {
1256     const char *hvname;
1257
1258     PERL_ARGS_ASSERT_DO_HV_DUMP;
1259
1260     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1261     if (sv && (hvname = HvNAME_get(sv)))
1262     {
1263         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1264            name which quite legally could contain insane things like tabs, newlines, nulls or
1265            other scary crap - this should produce sane results - except maybe for unicode package
1266            names - but we will wait for someone to file a bug on that - demerphq */
1267         SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1268         PerlIO_printf(file, "\t\"%s\"\n",
1269                               generic_pv_escape( tmpsv, hvname,
1270                                    HvNAMELEN(sv), HvNAMEUTF8(sv)));
1271     }
1272     else
1273         (void)PerlIO_putc(file, '\n');
1274 }
1275
1276 void
1277 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1278 {
1279     PERL_ARGS_ASSERT_DO_GV_DUMP;
1280
1281     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1282     if (sv && GvNAME(sv)) {
1283         SV * const tmpsv = newSVpvs("");
1284         PerlIO_printf(file, "\t\"%s\"\n",
1285                               generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1286     }
1287     else
1288         (void)PerlIO_putc(file, '\n');
1289 }
1290
1291 void
1292 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1293 {
1294     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1295
1296     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1297     if (sv && GvNAME(sv)) {
1298        SV *tmp = newSVpvs_flags("", SVs_TEMP);
1299         const char *hvname;
1300         HV * const stash = GvSTASH(sv);
1301         PerlIO_printf(file, "\t");
1302    /* TODO might have an extra \" here */
1303         if (stash && (hvname = HvNAME_get(stash))) {
1304             PerlIO_printf(file, "\"%s\" :: \"",
1305                                   generic_pv_escape(tmp, hvname,
1306                                       HvNAMELEN(stash), HvNAMEUTF8(stash)));
1307         }
1308         PerlIO_printf(file, "%s\"\n",
1309                               generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1310     }
1311     else
1312         (void)PerlIO_putc(file, '\n');
1313 }
1314
1315 const struct flag_to_name first_sv_flags_names[] = {
1316     {SVs_TEMP, "TEMP,"},
1317     {SVs_OBJECT, "OBJECT,"},
1318     {SVs_GMG, "GMG,"},
1319     {SVs_SMG, "SMG,"},
1320     {SVs_RMG, "RMG,"},
1321     {SVf_IOK, "IOK,"},
1322     {SVf_NOK, "NOK,"},
1323     {SVf_POK, "POK,"}
1324 };
1325
1326 const struct flag_to_name second_sv_flags_names[] = {
1327     {SVf_OOK, "OOK,"},
1328     {SVf_FAKE, "FAKE,"},
1329     {SVf_READONLY, "READONLY,"},
1330     {SVf_PROTECT, "PROTECT,"},
1331     {SVf_BREAK, "BREAK,"},
1332     {SVp_IOK, "pIOK,"},
1333     {SVp_NOK, "pNOK,"},
1334     {SVp_POK, "pPOK,"}
1335 };
1336
1337 const struct flag_to_name cv_flags_names[] = {
1338     {CVf_ANON, "ANON,"},
1339     {CVf_UNIQUE, "UNIQUE,"},
1340     {CVf_CLONE, "CLONE,"},
1341     {CVf_CLONED, "CLONED,"},
1342     {CVf_CONST, "CONST,"},
1343     {CVf_NODEBUG, "NODEBUG,"},
1344     {CVf_LVALUE, "LVALUE,"},
1345     {CVf_METHOD, "METHOD,"},
1346     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1347     {CVf_CVGV_RC, "CVGV_RC,"},
1348     {CVf_DYNFILE, "DYNFILE,"},
1349     {CVf_AUTOLOAD, "AUTOLOAD,"},
1350     {CVf_HASEVAL, "HASEVAL,"},
1351     {CVf_SLABBED, "SLABBED,"},
1352     {CVf_NAMED, "NAMED,"},
1353     {CVf_LEXICAL, "LEXICAL,"},
1354     {CVf_ISXSUB, "ISXSUB,"}
1355 };
1356
1357 const struct flag_to_name hv_flags_names[] = {
1358     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1359     {SVphv_LAZYDEL, "LAZYDEL,"},
1360     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1361     {SVf_AMAGIC, "OVERLOAD,"},
1362     {SVphv_CLONEABLE, "CLONEABLE,"}
1363 };
1364
1365 const struct flag_to_name gp_flags_names[] = {
1366     {GVf_INTRO, "INTRO,"},
1367     {GVf_MULTI, "MULTI,"},
1368     {GVf_ASSUMECV, "ASSUMECV,"},
1369 };
1370
1371 const struct flag_to_name gp_flags_imported_names[] = {
1372     {GVf_IMPORTED_SV, " SV"},
1373     {GVf_IMPORTED_AV, " AV"},
1374     {GVf_IMPORTED_HV, " HV"},
1375     {GVf_IMPORTED_CV, " CV"},
1376 };
1377
1378 /* NOTE: this structure is mostly duplicative of one generated by
1379  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1380  * the two. - Yves */
1381 const struct flag_to_name regexp_extflags_names[] = {
1382     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1383     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1384     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1385     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1386     {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1387     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1388     {RXf_PMf_NOCAPTURE,   "PMf_NOCAPURE,"},
1389     {RXf_IS_ANCHORED,     "IS_ANCHORED,"},
1390     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1391     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1392     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1393     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1394     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1395     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1396     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1397     {RXf_SPLIT,           "SPLIT,"},
1398     {RXf_COPY_DONE,       "COPY_DONE,"},
1399     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1400     {RXf_TAINTED,         "TAINTED,"},
1401     {RXf_START_ONLY,      "START_ONLY,"},
1402     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1403     {RXf_WHITE,           "WHITE,"},
1404     {RXf_NULL,            "NULL,"},
1405 };
1406
1407 /* NOTE: this structure is mostly duplicative of one generated by
1408  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1409  * the two. - Yves */
1410 const struct flag_to_name regexp_core_intflags_names[] = {
1411     {PREGf_SKIP,            "SKIP,"},
1412     {PREGf_IMPLICIT,        "IMPLICIT,"},
1413     {PREGf_NAUGHTY,         "NAUGHTY,"},
1414     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1415     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1416     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1417     {PREGf_NOSCAN,          "NOSCAN,"},
1418     {PREGf_GPOS_SEEN,       "GPOS_SEEN,"},
1419     {PREGf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1420     {PREGf_ANCH_MBOL,       "ANCH_MBOL,"},
1421     {PREGf_ANCH_SBOL,       "ANCH_SBOL,"},
1422     {PREGf_ANCH_GPOS,       "ANCH_GPOS,"},
1423 };
1424
1425 void
1426 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1427 {
1428     SV *d;
1429     const char *s;
1430     U32 flags;
1431     U32 type;
1432
1433     PERL_ARGS_ASSERT_DO_SV_DUMP;
1434
1435     if (!sv) {
1436         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1437         return;
1438     }
1439
1440     flags = SvFLAGS(sv);
1441     type = SvTYPE(sv);
1442
1443     /* process general SV flags */
1444
1445     d = Perl_newSVpvf(aTHX_
1446                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1447                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1448                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1449                    (int)(PL_dumpindent*level), "");
1450
1451     if ((flags & SVs_PADSTALE))
1452             sv_catpv(d, "PADSTALE,");
1453     if ((flags & SVs_PADTMP))
1454             sv_catpv(d, "PADTMP,");
1455     append_flags(d, flags, first_sv_flags_names);
1456     if (flags & SVf_ROK)  {
1457                                 sv_catpv(d, "ROK,");
1458         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1459     }
1460     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1461     append_flags(d, flags, second_sv_flags_names);
1462     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1463                            && type != SVt_PVAV) {
1464         if (SvPCS_IMPORTED(sv))
1465                                 sv_catpv(d, "PCS_IMPORTED,");
1466         else
1467                                 sv_catpv(d, "SCREAM,");
1468     }
1469
1470     /* process type-specific SV flags */
1471
1472     switch (type) {
1473     case SVt_PVCV:
1474     case SVt_PVFM:
1475         append_flags(d, CvFLAGS(sv), cv_flags_names);
1476         break;
1477     case SVt_PVHV:
1478         append_flags(d, flags, hv_flags_names);
1479         break;
1480     case SVt_PVGV:
1481     case SVt_PVLV:
1482         if (isGV_with_GP(sv)) {
1483             append_flags(d, GvFLAGS(sv), gp_flags_names);
1484         }
1485         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1486             sv_catpv(d, "IMPORT");
1487             if (GvIMPORTED(sv) == GVf_IMPORTED)
1488                 sv_catpv(d, "ALL,");
1489             else {
1490                 sv_catpv(d, "(");
1491                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1492                 sv_catpv(d, " ),");
1493             }
1494         }
1495         /* FALLTHROUGH */
1496     default:
1497     evaled_or_uv:
1498         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1499         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1500         break;
1501     case SVt_PVMG:
1502         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1503         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1504         /* FALLTHROUGH */
1505         goto evaled_or_uv;
1506     case SVt_PVAV:
1507         break;
1508     }
1509     /* SVphv_SHAREKEYS is also 0x20000000 */
1510     if ((type != SVt_PVHV) && SvUTF8(sv))
1511         sv_catpv(d, "UTF8");
1512
1513     if (*(SvEND(d) - 1) == ',') {
1514         SvCUR_set(d, SvCUR(d) - 1);
1515         SvPVX(d)[SvCUR(d)] = '\0';
1516     }
1517     sv_catpv(d, ")");
1518     s = SvPVX_const(d);
1519
1520     /* dump initial SV details */
1521
1522 #ifdef DEBUG_LEAKING_SCALARS
1523     Perl_dump_indent(aTHX_ level, file,
1524         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1525         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1526         sv->sv_debug_line,
1527         sv->sv_debug_inpad ? "for" : "by",
1528         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1529         PTR2UV(sv->sv_debug_parent),
1530         sv->sv_debug_serial
1531     );
1532 #endif
1533     Perl_dump_indent(aTHX_ level, file, "SV = ");
1534
1535     /* Dump SV type */
1536
1537     if (type < SVt_LAST) {
1538         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1539
1540         if (type ==  SVt_NULL) {
1541             SvREFCNT_dec_NN(d);
1542             return;
1543         }
1544     } else {
1545         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1546         SvREFCNT_dec_NN(d);
1547         return;
1548     }
1549
1550     /* Dump general SV fields */
1551
1552     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1553          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1554          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1555         || (type == SVt_IV && !SvROK(sv))) {
1556         if (SvIsUV(sv)
1557                                      )
1558             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1559         else
1560             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1561         (void)PerlIO_putc(file, '\n');
1562     }
1563
1564     if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1565                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1566                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1567                || type == SVt_NV) {
1568         STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1569         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1570         RESTORE_LC_NUMERIC_UNDERLYING();
1571     }
1572
1573     if (SvROK(sv)) {
1574         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1575         if (nest < maxnest)
1576             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1577     }
1578
1579     if (type < SVt_PV) {
1580         SvREFCNT_dec_NN(d);
1581         return;
1582     }
1583
1584     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1585      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1586         const bool re = isREGEXP(sv);
1587         const char * const ptr =
1588             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1589         if (ptr) {
1590             STRLEN delta;
1591             if (SvOOK(sv)) {
1592                 SvOOK_offset(sv, delta);
1593                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1594                                  (UV) delta);
1595             } else {
1596                 delta = 0;
1597             }
1598             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(ptr));
1599             if (SvOOK(sv)) {
1600                 PerlIO_printf(file, "( %s . ) ",
1601                               pv_display(d, ptr - delta, delta, 0,
1602                                          pvlim));
1603             }
1604             if (type == SVt_INVLIST) {
1605                 PerlIO_printf(file, "\n");
1606                 /* 4 blanks indents 2 beyond the PV, etc */
1607                 _invlist_dump(file, level, "    ", sv);
1608             }
1609             else {
1610                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1611                                                      re ? 0 : SvLEN(sv),
1612                                                      pvlim));
1613                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1614                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1615                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1616                                                         UNI_DISPLAY_QQ));
1617                 PerlIO_printf(file, "\n");
1618             }
1619             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1620             if (!re)
1621                 Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
1622                                        (IV)SvLEN(sv));
1623 #ifdef PERL_COPY_ON_WRITE
1624             if (SvIsCOW(sv) && SvLEN(sv))
1625                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1626                                        CowREFCNT(sv));
1627 #endif
1628         }
1629         else
1630             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1631     }
1632
1633     if (type >= SVt_PVMG) {
1634         if (SvMAGIC(sv))
1635                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1636         if (SvSTASH(sv))
1637             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1638
1639         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1640             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1641         }
1642     }
1643
1644     /* Dump type-specific SV fields */
1645
1646     switch (type) {
1647     case SVt_PVAV:
1648         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1649         if (AvARRAY(sv) != AvALLOC(sv)) {
1650             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1651             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1652         }
1653         else
1654             (void)PerlIO_putc(file, '\n');
1655         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1656         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1657         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n",
1658                                    SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1659         sv_setpvs(d, "");
1660         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1661         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1662         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1663                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1664         if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1665             SSize_t count;
1666             for (count = 0; count <=  av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1667                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1668
1669                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1670                 if (elt)
1671                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1672             }
1673         }
1674         break;
1675     case SVt_PVHV: {
1676         U32 usedkeys;
1677         if (SvOOK(sv)) {
1678             struct xpvhv_aux *const aux = HvAUX(sv);
1679             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %"UVuf"\n",
1680                              (UV)aux->xhv_aux_flags);
1681         }
1682         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1683         usedkeys = HvUSEDKEYS(sv);
1684         if (HvARRAY(sv) && usedkeys) {
1685             /* Show distribution of HEs in the ARRAY */
1686             int freq[200];
1687 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1688             int i;
1689             int max = 0;
1690             U32 pow2 = 2, keys = usedkeys;
1691             NV theoret, sum = 0;
1692
1693             PerlIO_printf(file, "  (");
1694             Zero(freq, FREQ_MAX + 1, int);
1695             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1696                 HE* h;
1697                 int count = 0;
1698                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1699                     count++;
1700                 if (count > FREQ_MAX)
1701                     count = FREQ_MAX;
1702                 freq[count]++;
1703                 if (max < count)
1704                     max = count;
1705             }
1706             for (i = 0; i <= max; i++) {
1707                 if (freq[i]) {
1708                     PerlIO_printf(file, "%d%s:%d", i,
1709                                   (i == FREQ_MAX) ? "+" : "",
1710                                   freq[i]);
1711                     if (i != max)
1712                         PerlIO_printf(file, ", ");
1713                 }
1714             }
1715             (void)PerlIO_putc(file, ')');
1716             /* The "quality" of a hash is defined as the total number of
1717                comparisons needed to access every element once, relative
1718                to the expected number needed for a random hash.
1719
1720                The total number of comparisons is equal to the sum of
1721                the squares of the number of entries in each bucket.
1722                For a random hash of n keys into k buckets, the expected
1723                value is
1724                                 n + n(n-1)/2k
1725             */
1726
1727             for (i = max; i > 0; i--) { /* Precision: count down. */
1728                 sum += freq[i] * i * i;
1729             }
1730             while ((keys = keys >> 1))
1731                 pow2 = pow2 << 1;
1732             theoret = usedkeys;
1733             theoret += theoret * (theoret-1)/pow2;
1734             (void)PerlIO_putc(file, '\n');
1735             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1736         }
1737         (void)PerlIO_putc(file, '\n');
1738         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)usedkeys);
1739         {
1740             STRLEN count = 0;
1741             HE **ents = HvARRAY(sv);
1742
1743             if (ents) {
1744                 HE *const *const last = ents + HvMAX(sv);
1745                 count = last + 1 - ents;
1746
1747                 do {
1748                     if (!*ents)
1749                         --count;
1750                 } while (++ents <= last);
1751             }
1752
1753             if (SvOOK(sv)) {
1754                 struct xpvhv_aux *const aux = HvAUX(sv);
1755                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf
1756                                  " (cached = %"UVuf")\n",
1757                                  (UV)count, (UV)aux->xhv_fill_lazy);
1758             } else {
1759                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
1760                                  (UV)count);
1761             }
1762         }
1763         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1764         if (SvOOK(sv)) {
1765             Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1766             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1767 #ifdef PERL_HASH_RANDOMIZE_KEYS
1768             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1769             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1770                 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1771             }
1772 #endif
1773             (void)PerlIO_putc(file, '\n');
1774         }
1775         {
1776             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1777             if (mg && mg->mg_obj) {
1778                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1779             }
1780         }
1781         {
1782             const char * const hvname = HvNAME_get(sv);
1783             if (hvname) {
1784           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1785      Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1786                                        generic_pv_escape( tmpsv, hvname,
1787                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
1788         }
1789         }
1790         if (SvOOK(sv)) {
1791             AV * const backrefs
1792                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1793             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1794             if (HvAUX(sv)->xhv_name_count)
1795                 Perl_dump_indent(aTHX_
1796                  level, file, "  NAMECOUNT = %"IVdf"\n",
1797                  (IV)HvAUX(sv)->xhv_name_count
1798                 );
1799             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1800                 const I32 count = HvAUX(sv)->xhv_name_count;
1801                 if (count) {
1802                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1803                     /* The starting point is the first element if count is
1804                        positive and the second element if count is negative. */
1805                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1806                         + (count < 0 ? 1 : 0);
1807                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1808                         + (count < 0 ? -count : count);
1809                     while (hekp < endp) {
1810                         if (HEK_LEN(*hekp)) {
1811              SV *tmp = newSVpvs_flags("", SVs_TEMP);
1812                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1813                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1814                         } else {
1815                             /* This should never happen. */
1816                             sv_catpvs(names, ", (null)");
1817                         }
1818                         ++hekp;
1819                     }
1820                     Perl_dump_indent(aTHX_
1821                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1822                     );
1823                 }
1824                 else {
1825                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1826                     const char *const hvename = HvENAME_get(sv);
1827                     Perl_dump_indent(aTHX_
1828                      level, file, "  ENAME = \"%s\"\n",
1829                      generic_pv_escape(tmp, hvename,
1830                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1831                 }
1832             }
1833             if (backrefs) {
1834                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1835                                  PTR2UV(backrefs));
1836                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1837                            dumpops, pvlim);
1838             }
1839             if (meta) {
1840                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1841                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1842                                  generic_pv_escape( tmpsv, meta->mro_which->name,
1843                                 meta->mro_which->length,
1844                                 (meta->mro_which->kflags & HVhek_UTF8)),
1845                                  PTR2UV(meta->mro_which));
1846                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1847                                  (UV)meta->cache_gen);
1848                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1849                                  (UV)meta->pkg_gen);
1850                 if (meta->mro_linear_all) {
1851                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1852                                  PTR2UV(meta->mro_linear_all));
1853                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1854                            dumpops, pvlim);
1855                 }
1856                 if (meta->mro_linear_current) {
1857                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1858                                  PTR2UV(meta->mro_linear_current));
1859                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1860                            dumpops, pvlim);
1861                 }
1862                 if (meta->mro_nextmethod) {
1863                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1864                                  PTR2UV(meta->mro_nextmethod));
1865                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1866                            dumpops, pvlim);
1867                 }
1868                 if (meta->isa) {
1869                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1870                                  PTR2UV(meta->isa));
1871                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1872                            dumpops, pvlim);
1873                 }
1874             }
1875         }
1876         if (nest < maxnest) {
1877             HV * const hv = MUTABLE_HV(sv);
1878             STRLEN i;
1879             HE *he;
1880
1881             if (HvARRAY(hv)) {
1882                 int count = maxnest - nest;
1883                 for (i=0; i <= HvMAX(hv); i++) {
1884                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1885                         U32 hash;
1886                         SV * keysv;
1887                         const char * keypv;
1888                         SV * elt;
1889                         STRLEN len;
1890
1891                         if (count-- <= 0) goto DONEHV;
1892
1893                         hash = HeHASH(he);
1894                         keysv = hv_iterkeysv(he);
1895                         keypv = SvPV_const(keysv, len);
1896                         elt = HeVAL(he);
1897
1898                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1899                         if (SvUTF8(keysv))
1900                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1901                         if (HvEITER_get(hv) == he)
1902                             PerlIO_printf(file, "[CURRENT] ");
1903                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1904                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1905                     }
1906                 }
1907               DONEHV:;
1908             }
1909         }
1910         break;
1911     } /* case SVt_PVHV */
1912
1913     case SVt_PVCV:
1914         if (CvAUTOLOAD(sv)) {
1915             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1916        STRLEN len;
1917             const char *const name =  SvPV_const(sv, len);
1918             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
1919                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1920         }
1921         if (SvPOK(sv)) {
1922        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1923        const char *const proto = CvPROTO(sv);
1924             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
1925                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1926                                 SvUTF8(sv)));
1927         }
1928         /* FALLTHROUGH */
1929     case SVt_PVFM:
1930         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1931         if (!CvISXSUB(sv)) {
1932             if (CvSTART(sv)) {
1933                 Perl_dump_indent(aTHX_ level, file,
1934                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1935                                  PTR2UV(CvSTART(sv)),
1936                                  (IV)sequence_num(CvSTART(sv)));
1937             }
1938             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1939                              PTR2UV(CvROOT(sv)));
1940             if (CvROOT(sv) && dumpops) {
1941                 do_op_dump(level+1, file, CvROOT(sv));
1942             }
1943         } else {
1944             SV * const constant = cv_const_sv((const CV *)sv);
1945
1946             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1947
1948             if (constant) {
1949                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1950                                  " (CONST SV)\n",
1951                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1952                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1953                            pvlim);
1954             } else {
1955                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1956                                  (IV)CvXSUBANY(sv).any_i32);
1957             }
1958         }
1959         if (CvNAMED(sv))
1960             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1961                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
1962         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1963         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1964         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1965         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1966         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1967         if (!CvISXSUB(sv)) {
1968             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1969             if (nest < maxnest) {
1970                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1971             }
1972         }
1973         else
1974             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
1975         {
1976             const CV * const outside = CvOUTSIDE(sv);
1977             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1978                         PTR2UV(outside),
1979                         (!outside ? "null"
1980                          : CvANON(outside) ? "ANON"
1981                          : (outside == PL_main_cv) ? "MAIN"
1982                          : CvUNIQUE(outside) ? "UNIQUE"
1983                          : CvGV(outside) ?
1984                              generic_pv_escape(
1985                                  newSVpvs_flags("", SVs_TEMP),
1986                                  GvNAME(CvGV(outside)),
1987                                  GvNAMELEN(CvGV(outside)),
1988                                  GvNAMEUTF8(CvGV(outside)))
1989                          : "UNDEFINED"));
1990         }
1991         if (CvOUTSIDE(sv)
1992          && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
1993             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1994         break;
1995
1996     case SVt_PVGV:
1997     case SVt_PVLV:
1998         if (type == SVt_PVLV) {
1999             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2000             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2001             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2002             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2003             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2004             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2005                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2006                     dumpops, pvlim);
2007         }
2008         if (isREGEXP(sv)) goto dumpregexp;
2009         if (!isGV_with_GP(sv))
2010             break;
2011        {
2012           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2013           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2014                     generic_pv_escape(tmpsv, GvNAME(sv),
2015                                       GvNAMELEN(sv),
2016                                       GvNAMEUTF8(sv)));
2017        }
2018         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2019         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2020         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2021         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2022         if (!GvGP(sv))
2023             break;
2024         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2025         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2026         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2027         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2028         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2029         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2030         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2031         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2032         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%"UVxf
2033                                             " (%s)\n",
2034                                (UV)GvGPFLAGS(sv),
2035                                "");
2036         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2037         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2038         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2039         break;
2040     case SVt_PVIO:
2041         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2042         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2043         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2044         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2045         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2046         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2047         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2048         if (IoTOP_NAME(sv))
2049             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2050         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2051             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2052         else {
2053             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2054                              PTR2UV(IoTOP_GV(sv)));
2055             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2056                         maxnest, dumpops, pvlim);
2057         }
2058         /* Source filters hide things that are not GVs in these three, so let's
2059            be careful out there.  */
2060         if (IoFMT_NAME(sv))
2061             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2062         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2063             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2064         else {
2065             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2066                              PTR2UV(IoFMT_GV(sv)));
2067             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2068                         maxnest, dumpops, pvlim);
2069         }
2070         if (IoBOTTOM_NAME(sv))
2071             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2072         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2073             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2074         else {
2075             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2076                              PTR2UV(IoBOTTOM_GV(sv)));
2077             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2078                         maxnest, dumpops, pvlim);
2079         }
2080         if (isPRINT(IoTYPE(sv)))
2081             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2082         else
2083             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2084         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2085         break;
2086     case SVt_REGEXP:
2087       dumpregexp:
2088         {
2089             struct regexp * const r = ReANY((REGEXP*)sv);
2090
2091 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2092             sv_setpv(d,"");                                 \
2093             append_flags(d, flags, names);     \
2094             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2095                 SvCUR_set(d, SvCUR(d) - 1);                 \
2096                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2097             }                                               \
2098 } STMT_END
2099             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2100             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
2101                                 (UV)(r->compflags), SvPVX_const(d));
2102
2103             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2104             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2105                                 (UV)(r->extflags), SvPVX_const(d));
2106
2107             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf" (%s)\n",
2108                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2109             if (r->engine == &PL_core_reg_engine) {
2110                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2111                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf" (%s)\n",
2112                                 (UV)(r->intflags), SvPVX_const(d));
2113             } else {
2114                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2115                                 (UV)(r->intflags));
2116             }
2117 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2118             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2119                                 (UV)(r->nparens));
2120             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2121                                 (UV)(r->lastparen));
2122             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2123                                 (UV)(r->lastcloseparen));
2124             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2125                                 (IV)(r->minlen));
2126             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2127                                 (IV)(r->minlenret));
2128             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2129                                 (UV)(r->gofs));
2130             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2131                                 (UV)(r->pre_prefix));
2132             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2133                                 (IV)(r->sublen));
2134             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
2135                                 (IV)(r->suboffset));
2136             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
2137                                 (IV)(r->subcoffset));
2138             if (r->subbeg)
2139                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2140                             PTR2UV(r->subbeg),
2141                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2142             else
2143                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2144             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2145                                 PTR2UV(r->mother_re));
2146             if (nest < maxnest && r->mother_re)
2147                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2148                            maxnest, dumpops, pvlim);
2149             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2150                                 PTR2UV(r->paren_names));
2151             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2152                                 PTR2UV(r->substrs));
2153             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2154                                 PTR2UV(r->pprivate));
2155             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2156                                 PTR2UV(r->offs));
2157             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2158                                 PTR2UV(r->qr_anoncv));
2159 #ifdef PERL_ANY_COW
2160             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2161                                 PTR2UV(r->saved_copy));
2162 #endif
2163         }
2164         break;
2165     }
2166     SvREFCNT_dec_NN(d);
2167 }
2168
2169 /*
2170 =for apidoc sv_dump
2171
2172 Dumps the contents of an SV to the C<STDERR> filehandle.
2173
2174 For an example of its output, see L<Devel::Peek>.
2175
2176 =cut
2177 */
2178
2179 void
2180 Perl_sv_dump(pTHX_ SV *sv)
2181 {
2182     PERL_ARGS_ASSERT_SV_DUMP;
2183
2184     if (SvROK(sv))
2185         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2186     else
2187         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2188 }
2189
2190 int
2191 Perl_runops_debug(pTHX)
2192 {
2193     if (!PL_op) {
2194         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2195         return 0;
2196     }
2197
2198     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2199     do {
2200 #ifdef PERL_TRACE_OPS
2201         ++PL_op_exec_cnt[PL_op->op_type];
2202 #endif
2203         if (PL_debug) {
2204             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2205                 PerlIO_printf(Perl_debug_log,
2206                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2207                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2208                               PTR2UV(*PL_watchaddr));
2209             if (DEBUG_s_TEST_) {
2210                 if (DEBUG_v_TEST_) {
2211                     PerlIO_printf(Perl_debug_log, "\n");
2212                     deb_stack_all();
2213                 }
2214                 else
2215                     debstack();
2216             }
2217
2218
2219             if (DEBUG_t_TEST_) debop(PL_op);
2220             if (DEBUG_P_TEST_) debprof(PL_op);
2221         }
2222
2223         OP_ENTRY_PROBE(OP_NAME(PL_op));
2224     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2225     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2226     PERL_ASYNC_CHECK();
2227
2228     TAINT_NOT;
2229     return 0;
2230 }
2231
2232
2233 /* print the names of the n lexical vars starting at pad offset off */
2234
2235 STATIC void
2236 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2237 {
2238     PADNAME *sv;
2239     CV * const cv = deb_curcv(cxstack_ix);
2240     PADNAMELIST *comppad = NULL;
2241     int i;
2242
2243     if (cv) {
2244         PADLIST * const padlist = CvPADLIST(cv);
2245         comppad = PadlistNAMES(padlist);
2246     }
2247     if (paren)
2248         PerlIO_printf(Perl_debug_log, "(");
2249     for (i = 0; i < n; i++) {
2250         if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2251             PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2252         else
2253             PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2254                     (UV)(off+i));
2255         if (i < n - 1)
2256             PerlIO_printf(Perl_debug_log, ",");
2257     }
2258     if (paren)
2259         PerlIO_printf(Perl_debug_log, ")");
2260 }
2261
2262
2263 /* append to the out SV, the name of the lexical at offset off in the CV
2264  * cv */
2265
2266 static void
2267 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2268         bool paren, bool is_scalar)
2269 {
2270     PADNAME *sv;
2271     PADNAMELIST *namepad = NULL;
2272     int i;
2273
2274     if (cv) {
2275         PADLIST * const padlist = CvPADLIST(cv);
2276         namepad = PadlistNAMES(padlist);
2277     }
2278
2279     if (paren)
2280         sv_catpvs_nomg(out, "(");
2281     for (i = 0; i < n; i++) {
2282         if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2283         {
2284             STRLEN cur = SvCUR(out);
2285             Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2286                                  UTF8fARG(1, PadnameLEN(sv) - 1,
2287                                           PadnamePV(sv) + 1));
2288             if (is_scalar)
2289                 SvPVX(out)[cur] = '$';
2290         }
2291         else
2292             Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2293         if (i < n - 1)
2294             sv_catpvs_nomg(out, ",");
2295     }
2296     if (paren)
2297         sv_catpvs_nomg(out, "(");
2298 }
2299
2300
2301 static void
2302 S_append_gv_name(pTHX_ GV *gv, SV *out)
2303 {
2304     SV *sv;
2305     if (!gv) {
2306         sv_catpvs_nomg(out, "<NULLGV>");
2307         return;
2308     }
2309     sv = newSV(0);
2310     gv_fullname4(sv, gv, NULL, FALSE);
2311     Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv));
2312     SvREFCNT_dec_NN(sv);
2313 }
2314
2315 #ifdef USE_ITHREADS
2316 #  define ITEM_SV(item) (comppad ? \
2317     *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2318 #else
2319 #  define ITEM_SV(item) UNOP_AUX_item_sv(item)
2320 #endif
2321
2322
2323 /* return a temporary SV containing a stringified representation of
2324  * the op_aux field of a MULTIDEREF op, associated with CV cv
2325  */
2326
2327 SV*
2328 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2329 {
2330     UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2331     UV actions = items->uv;
2332     SV *sv;
2333     bool last = 0;
2334     bool is_hash = FALSE;
2335     int derefs = 0;
2336     SV *out = newSVpvn_flags("",0,SVs_TEMP);
2337 #ifdef USE_ITHREADS
2338     PAD *comppad;
2339
2340     if (cv) {
2341         PADLIST *padlist = CvPADLIST(cv);
2342         comppad = PadlistARRAY(padlist)[1];
2343     }
2344     else
2345         comppad = NULL;
2346 #endif
2347
2348     PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2349
2350     while (!last) {
2351         switch (actions & MDEREF_ACTION_MASK) {
2352
2353         case MDEREF_reload:
2354             actions = (++items)->uv;
2355             continue;
2356             NOT_REACHED; /* NOTREACHED */
2357
2358         case MDEREF_HV_padhv_helem:
2359             is_hash = TRUE;
2360             /* FALLTHROUGH */
2361         case MDEREF_AV_padav_aelem:
2362             derefs = 1;
2363             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2364             goto do_elem;
2365             NOT_REACHED; /* NOTREACHED */
2366
2367         case MDEREF_HV_gvhv_helem:
2368             is_hash = TRUE;
2369             /* FALLTHROUGH */
2370         case MDEREF_AV_gvav_aelem:
2371             derefs = 1;
2372             items++;
2373             sv = ITEM_SV(items);
2374             S_append_gv_name(aTHX_ (GV*)sv, out);
2375             goto do_elem;
2376             NOT_REACHED; /* NOTREACHED */
2377
2378         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2379             is_hash = TRUE;
2380             /* FALLTHROUGH */
2381         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2382             items++;
2383             sv = ITEM_SV(items);
2384             S_append_gv_name(aTHX_ (GV*)sv, out);
2385             goto do_vivify_rv2xv_elem;
2386             NOT_REACHED; /* NOTREACHED */
2387
2388         case MDEREF_HV_padsv_vivify_rv2hv_helem:
2389             is_hash = TRUE;
2390             /* FALLTHROUGH */
2391         case MDEREF_AV_padsv_vivify_rv2av_aelem:
2392             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2393             goto do_vivify_rv2xv_elem;
2394             NOT_REACHED; /* NOTREACHED */
2395
2396         case MDEREF_HV_pop_rv2hv_helem:
2397         case MDEREF_HV_vivify_rv2hv_helem:
2398             is_hash = TRUE;
2399             /* FALLTHROUGH */
2400         do_vivify_rv2xv_elem:
2401         case MDEREF_AV_pop_rv2av_aelem:
2402         case MDEREF_AV_vivify_rv2av_aelem:
2403             if (!derefs++)
2404                 sv_catpvs_nomg(out, "->");
2405         do_elem:
2406             if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2407                 sv_catpvs_nomg(out, "->");
2408                 last = 1;
2409                 break;
2410             }
2411
2412             sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2413             switch (actions & MDEREF_INDEX_MASK) {
2414             case MDEREF_INDEX_const:
2415                 if (is_hash) {
2416                     items++;
2417                     sv = ITEM_SV(items);
2418                     if (!sv)
2419                         sv_catpvs_nomg(out, "???");
2420                     else {
2421                         STRLEN cur;
2422                         char *s;
2423                         s = SvPV(sv, cur);
2424                         pv_pretty(out, s, cur, 30,
2425                                     NULL, NULL,
2426                                     (PERL_PV_PRETTY_NOCLEAR
2427                                     |PERL_PV_PRETTY_QUOTE
2428                                     |PERL_PV_PRETTY_ELLIPSES));
2429                     }
2430                 }
2431                 else
2432                     Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2433                 break;
2434             case MDEREF_INDEX_padsv:
2435                 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2436                 break;
2437             case MDEREF_INDEX_gvsv:
2438                 items++;
2439                 sv = ITEM_SV(items);
2440                 S_append_gv_name(aTHX_ (GV*)sv, out);
2441                 break;
2442             }
2443             sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2444
2445             if (actions & MDEREF_FLAG_last)
2446                 last = 1;
2447             is_hash = FALSE;
2448
2449             break;
2450
2451         default:
2452             PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2453                 (int)(actions & MDEREF_ACTION_MASK));
2454             last = 1;
2455             break;
2456
2457         } /* switch */
2458
2459         actions >>= MDEREF_SHIFT;
2460     } /* while */
2461     return out;
2462 }
2463
2464
2465 I32
2466 Perl_debop(pTHX_ const OP *o)
2467 {
2468     PERL_ARGS_ASSERT_DEBOP;
2469
2470     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2471         return 0;
2472
2473     Perl_deb(aTHX_ "%s", OP_NAME(o));
2474     switch (o->op_type) {
2475     case OP_CONST:
2476     case OP_HINTSEVAL:
2477         /* With ITHREADS, consts are stored in the pad, and the right pad
2478          * may not be active here, so check.
2479          * Looks like only during compiling the pads are illegal.
2480          */
2481 #ifdef USE_ITHREADS
2482         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2483 #endif
2484             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2485         break;
2486     case OP_GVSV:
2487     case OP_GV:
2488         if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2489             SV * const sv = newSV(0);
2490             gv_fullname3(sv, cGVOPo_gv, NULL);
2491             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2492             SvREFCNT_dec_NN(sv);
2493         }
2494         else if (cGVOPo_gv) {
2495             SV * const sv = newSV(0);
2496             assert(SvROK(cGVOPo_gv));
2497             assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2498             PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2499                     SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2500             SvREFCNT_dec_NN(sv);
2501         }
2502         else
2503             PerlIO_printf(Perl_debug_log, "(NULL)");
2504         break;
2505
2506     case OP_PADSV:
2507     case OP_PADAV:
2508     case OP_PADHV:
2509         S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2510         break;
2511
2512     case OP_PADRANGE:
2513         S_deb_padvar(aTHX_ o->op_targ,
2514                         o->op_private & OPpPADRANGE_COUNTMASK, 1);
2515         break;
2516
2517     case OP_MULTIDEREF:
2518         PerlIO_printf(Perl_debug_log, "(%"SVf")",
2519             SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2520         break;
2521
2522     default:
2523         break;
2524     }
2525     PerlIO_printf(Perl_debug_log, "\n");
2526     return 0;
2527 }
2528
2529 STATIC CV*
2530 S_deb_curcv(pTHX_ I32 ix)
2531 {
2532     PERL_SI *si = PL_curstackinfo;
2533     for (; ix >=0; ix--) {
2534         const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2535
2536         if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2537             return cx->blk_sub.cv;
2538         else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2539             return cx->blk_eval.cv;
2540         else if (ix == 0 && si->si_type == PERLSI_MAIN)
2541             return PL_main_cv;
2542         else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2543                && si->si_type == PERLSI_SORT)
2544         {
2545             /* fake sort sub; use CV of caller */
2546             si = si->si_prev;
2547             ix = si->si_cxix + 1;
2548         }
2549     }
2550     return NULL;
2551 }
2552
2553 void
2554 Perl_watch(pTHX_ char **addr)
2555 {
2556     PERL_ARGS_ASSERT_WATCH;
2557
2558     PL_watchaddr = addr;
2559     PL_watchok = *addr;
2560     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2561         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2562 }
2563
2564 STATIC void
2565 S_debprof(pTHX_ const OP *o)
2566 {
2567     PERL_ARGS_ASSERT_DEBPROF;
2568
2569     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2570         return;
2571     if (!PL_profiledata)
2572         Newxz(PL_profiledata, MAXO, U32);
2573     ++PL_profiledata[o->op_type];
2574 }
2575
2576 void
2577 Perl_debprofdump(pTHX)
2578 {
2579     unsigned i;
2580     if (!PL_profiledata)
2581         return;
2582     for (i = 0; i < MAXO; i++) {
2583         if (PL_profiledata[i])
2584             PerlIO_printf(Perl_debug_log,
2585                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2586                                        PL_op_name[i]);
2587     }
2588 }
2589
2590
2591 /*
2592  * ex: set ts=8 sts=4 sw=4 et:
2593  */