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 "count" chars of pv and puts the results into
  98 dsv such that the size of the escaped string will not exceed "max" chars
  99 and will not contain any incomplete escape sequences.  The number of bytes
 100 escaped will be returned in the STRLEN *escaped parameter if it is not null.
 101 When the 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 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 PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
 109
 110 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
 111 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
 112 using C<is_utf8_string()> to determine if it is Unicode.
 113
 114 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
 115 using C<\x01F1> style escapes, otherwise if 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 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 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 PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
 130 not a '\\'.  This is because regexes very often contain backslashed
 131 sequences, whereas '%' is not a particularly common character in patterns.
 132
 133 Returns a pointer to the escaped text as held by 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 Unicode */
 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 pv_escape() and supporting quoting and ellipses.
 253
 254 If the 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 PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
 257 angle brackets.
 258
 259 If the 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 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 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 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_NUMERIC_LOCAL_SET_STANDARD();
 481         Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
 482         RESTORE_NUMERIC_LOCAL();
 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             const GV * const gv = (const GV *)HeVAL(entry);
 576             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 577                 continue;
 578             if (GvCVu(gv))
 579                 dump_sub_perl(gv, justperl);
 580             if (GvFORM(gv))
 581                 dump_form(gv);
 582             if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
 583                 const HV * const hv = GvHV(gv);
 584                 if (hv && (hv != PL_defstash))
 585                     dump_packsubs_perl(hv, justperl); /* nested package */
 586             }
 587         }
 588     }
 589 }
 590
 591 void
 592 Perl_dump_sub(pTHX_ const GV *gv)
 593 {
 594     PERL_ARGS_ASSERT_DUMP_SUB;
 595     dump_sub_perl(gv, FALSE);
 596 }
 597
 598 void
 599 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
 600 {
 601     STRLEN len;
 602     SV * const sv = newSVpvs_flags("", SVs_TEMP);
 603     SV *tmpsv;
 604     const char * name;
 605
 606     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
 607
 608     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
 609         return;
 610
 611     tmpsv = newSVpvs_flags("", SVs_TEMP);
 612     gv_fullname3(sv, gv, NULL);
 613     name = SvPV_const(sv, len);
 614     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
 615                      generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
 616     if (CvISXSUB(GvCV(gv)))
 617         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
 618             PTR2UV(CvXSUB(GvCV(gv))),
 619             (int)CvXSUBANY(GvCV(gv)).any_i32);
 620     else if (CvROOT(GvCV(gv)))
 621         op_dump(CvROOT(GvCV(gv)));
 622     else
 623         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 624 }
 625
 626 void
 627 Perl_dump_form(pTHX_ const GV *gv)
 628 {
 629     SV * const sv = sv_newmortal();
 630
 631     PERL_ARGS_ASSERT_DUMP_FORM;
 632
 633     gv_fullname3(sv, gv, NULL);
 634     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
 635     if (CvROOT(GvFORM(gv)))
 636         op_dump(CvROOT(GvFORM(gv)));
 637     else
 638         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 639 }
 640
 641 void
 642 Perl_dump_eval(pTHX)
 643 {
 644     op_dump(PL_eval_root);
 645 }
 646
 647 void
 648 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
 649 {
 650     char ch;
 651
 652     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
 653
 654     if (!pm) {
 655         Perl_dump_indent(aTHX_ level, file, "{}\n");
 656         return;
 657     }
 658     Perl_dump_indent(aTHX_ level, file, "{\n");
 659     level++;
 660     if (pm->op_pmflags & PMf_ONCE)
 661         ch = '?';
 662     else
 663         ch = '/';
 664     if (PM_GETRE(pm))
 665         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n",
 666              ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch,
 667              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
 668     else
 669         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
 670     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
 671         Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
 672         op_dump(pm->op_pmreplrootu.op_pmreplroot);
 673     }
 674     if (pm->op_code_list) {
 675         if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
 676             Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
 677             do_op_dump(level, file, pm->op_code_list);
 678         }
 679         else
 680             Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
 681                                     PTR2UV(pm->op_code_list));
 682     }
 683     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
 684         SV * const tmpsv = pm_description(pm);
 685         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 686         SvREFCNT_dec_NN(tmpsv);
 687     }
 688
 689     Perl_dump_indent(aTHX_ level-1, file, "}\n");
 690 }
 691
 692 const struct flag_to_name pmflags_flags_names[] = {
 693     {PMf_CONST, ",CONST"},
 694     {PMf_KEEP, ",KEEP"},
 695     {PMf_GLOBAL, ",GLOBAL"},
 696     {PMf_CONTINUE, ",CONTINUE"},
 697     {PMf_RETAINT, ",RETAINT"},
 698     {PMf_EVAL, ",EVAL"},
 699     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
 700     {PMf_HAS_CV, ",HAS_CV"},
 701     {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
 702     {PMf_IS_QR, ",IS_QR"}
 703 };
 704
 705 static SV *
 706 S_pm_description(pTHX_ const PMOP *pm)
 707 {
 708     SV * const desc = newSVpvs("");
 709     const REGEXP * const regex = PM_GETRE(pm);
 710     const U32 pmflags = pm->op_pmflags;
 711
 712     PERL_ARGS_ASSERT_PM_DESCRIPTION;
 713
 714     if (pmflags & PMf_ONCE)
 715         sv_catpv(desc, ",ONCE");
 716 #ifdef USE_ITHREADS
 717     if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
 718         sv_catpv(desc, ":USED");
 719 #else
 720     if (pmflags & PMf_USED)
 721         sv_catpv(desc, ":USED");
 722 #endif
 723
 724     if (regex) {
 725         if (RX_ISTAINTED(regex))
 726             sv_catpv(desc, ",TAINTED");
 727         if (RX_CHECK_SUBSTR(regex)) {
 728             if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
 729                 sv_catpv(desc, ",SCANFIRST");
 730             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
 731                 sv_catpv(desc, ",ALL");
 732         }
 733         if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
 734             sv_catpv(desc, ",SKIPWHITE");
 735     }
 736
 737     append_flags(desc, pmflags, pmflags_flags_names);
 738     return desc;
 739 }
 740
 741 void
 742 Perl_pmop_dump(pTHX_ PMOP *pm)
 743 {
 744     do_pmop_dump(0, Perl_debug_log, pm);
 745 }
 746
 747 /* Return a unique integer to represent the address of op o.
 748  * If it already exists in PL_op_sequence, just return it;
 749  * otherwise add it.
 750  *  *** Note that this isn't thread-safe */
 751
 752 STATIC UV
 753 S_sequence_num(pTHX_ const OP *o)
 754 {
 755     dVAR;
 756     SV     *op,
 757           **seq;
 758     const char *key;
 759     STRLEN  len;
 760     if (!o)
 761         return 0;
 762     op = newSVuv(PTR2UV(o));
 763     sv_2mortal(op);
 764     key = SvPV_const(op, len);
 765     if (!PL_op_sequence)
 766         PL_op_sequence = newHV();
 767     seq = hv_fetch(PL_op_sequence, key, len, 0);
 768     if (seq)
 769         return SvUV(*seq);
 770     (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
 771     return PL_op_seq;
 772 }
 773
 774
 775
 776
 777
 778 const struct flag_to_name op_flags_names[] = {
 779     {OPf_KIDS, ",KIDS"},
 780     {OPf_PARENS, ",PARENS"},
 781     {OPf_REF, ",REF"},
 782     {OPf_MOD, ",MOD"},
 783     {OPf_STACKED, ",STACKED"},
 784     {OPf_SPECIAL, ",SPECIAL"}
 785 };
 786
 787
 788 void
 789 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 790 {
 791     UV      seq;
 792     const OPCODE optype = o->op_type;
 793
 794     PERL_ARGS_ASSERT_DO_OP_DUMP;
 795
 796     Perl_dump_indent(aTHX_ level, file, "{\n");
 797     level++;
 798     seq = sequence_num(o);
 799     if (seq)
 800         PerlIO_printf(file, "%-4"UVuf, seq);
 801     else
 802         PerlIO_printf(file, "????");
 803     PerlIO_printf(file,
 804                   "%*sTYPE = %s  ===> ",
 805                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
 806     if (o->op_next)
 807         PerlIO_printf(file,
 808                         o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
 809                                 sequence_num(o->op_next));
 810     else
 811         PerlIO_printf(file, "NULL\n");
 812     if (o->op_targ) {
 813         if (optype == OP_NULL) {
 814             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
 815         }
 816         else
 817             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
 818     }
 819 #ifdef DUMPADDR
 820     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
 821 #endif
 822
 823     if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
 824         SV * const tmpsv = newSVpvs("");
 825         switch (o->op_flags & OPf_WANT) {
 826         case OPf_WANT_VOID:
 827             sv_catpv(tmpsv, ",VOID");
 828             break;
 829         case OPf_WANT_SCALAR:
 830             sv_catpv(tmpsv, ",SCALAR");
 831             break;
 832         case OPf_WANT_LIST:
 833             sv_catpv(tmpsv, ",LIST");
 834             break;
 835         default:
 836             sv_catpv(tmpsv, ",UNKNOWN");
 837             break;
 838         }
 839         append_flags(tmpsv, o->op_flags, op_flags_names);
 840         if (o->op_slabbed)  sv_catpvs(tmpsv, ",SLABBED");
 841         if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
 842         if (o->op_static)   sv_catpvs(tmpsv, ",STATIC");
 843         if (o->op_folded)   sv_catpvs(tmpsv, ",FOLDED");
 844         if (o->op_lastsib)  sv_catpvs(tmpsv, ",LASTSIB");
 845         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
 846                          SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 847     }
 848
 849     if (o->op_private) {
 850         U16 oppriv = o->op_private;
 851         I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
 852         SV * tmpsv = NULL;
 853
 854         if (op_ix != -1) {
 855             U16 stop = 0;
 856             tmpsv = newSVpvs("");
 857             for (; !stop; op_ix++) {
 858                 U16 entry = PL_op_private_bitdefs[op_ix];
 859                 U16 bit = (entry >> 2) & 7;
 860                 U16 ix = entry >> 5;
 861
 862                 stop = (entry & 1);
 863
 864                 if (entry & 2) {
 865                     /* bitfield */
 866                     I16 const *p = &PL_op_private_bitfields[ix];
 867                     U16 bitmin = (U16) *p++;
 868                     I16 label = *p++;
 869                     I16 enum_label;
 870                     U16 mask = 0;
 871                     U16 i;
 872                     U16 val;
 873
 874                     for (i = bitmin; i<= bit; i++)
 875                         mask |= (1<<i);
 876                     bit = bitmin;
 877                     val = (oppriv & mask);
 878
 879                     if (   label != -1
 880                         && PL_op_private_labels[label] == '-'
 881                         && PL_op_private_labels[label+1] == '\0'
 882                     )
 883                         /* display as raw number */
 884                         continue;
 885
 886                     oppriv -= val;
 887                     val >>= bit;
 888                     enum_label = -1;
 889                     while (*p != -1) {
 890                         if (val == *p++) {
 891                             enum_label = *p;
 892                             break;
 893                         }
 894                         p++;
 895                     }
 896                     if (val == 0 && enum_label == -1)
 897                         /* don't display anonymous zero values */
 898                         continue;
 899
 900                     sv_catpv(tmpsv, ",");
 901                     if (label != -1) {
 902                         sv_catpv(tmpsv, &PL_op_private_labels[label]);
 903                         sv_catpv(tmpsv, "=");
 904                     }
 905                     sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
 906
 907                 }
 908                 else {
 909                     /* bit flag */
 910                     if (   oppriv & (1<<bit)
 911                         && !(PL_op_private_labels[ix] == '-'
 912                              && PL_op_private_labels[ix+1] == '\0'))
 913                     {
 914                         oppriv -= (1<<bit);
 915                         sv_catpv(tmpsv, ",");
 916                         sv_catpv(tmpsv, &PL_op_private_labels[ix]);
 917                     }
 918                 }
 919             }
 920             if (oppriv) {
 921                 sv_catpv(tmpsv, ",");
 922                 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
 923             }
 924         }
 925         if (tmpsv && SvCUR(tmpsv)) {
 926             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
 927         } else
 928             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
 929                              (UV)oppriv);
 930     }
 931
 932     switch (optype) {
 933     case OP_AELEMFAST:
 934     case OP_GVSV:
 935     case OP_GV:
 936 #ifdef USE_ITHREADS
 937         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
 938 #else
 939         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
 940             if (cSVOPo->op_sv) {
 941       STRLEN len;
 942       const char * name;
 943       SV * const tmpsv  = newSVpvs_flags("", SVs_TEMP);
 944       SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
 945                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
 946       name = SvPV_const(tmpsv, len);
 947                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
 948                        generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
 949             }
 950             else
 951                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
 952         }
 953 #endif
 954         break;
 955     case OP_CONST:
 956     case OP_HINTSEVAL:
 957     case OP_METHOD_NAMED:
 958     case OP_METHOD_SUPER:
 959 #ifndef USE_ITHREADS
 960         /* with ITHREADS, consts are stored in the pad, and the right pad
 961          * may not be active here, so skip */
 962         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
 963 #endif
 964         break;
 965     case OP_NULL:
 966         if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
 967             break;
 968         /* FALLTHROUGH */
 969     case OP_NEXTSTATE:
 970     case OP_DBSTATE:
 971         if (CopLINE(cCOPo))
 972             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
 973                              (UV)CopLINE(cCOPo));
 974     if (CopSTASHPV(cCOPo)) {
 975         SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
 976         HV *stash = CopSTASH(cCOPo);
 977         const char * const hvname = HvNAME_get(stash);
 978
 979             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
 980                            generic_pv_escape(tmpsv, hvname,
 981                               HvNAMELEN(stash), HvNAMEUTF8(stash)));
 982     }
 983   if (CopLABEL(cCOPo)) {
 984        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
 985        STRLEN label_len;
 986        U32 label_flags;
 987        const char *label = CopLABEL_len_flags(cCOPo,
 988                                                 &label_len, &label_flags);
 989        Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
 990                            generic_pv_escape( tmpsv, label, label_len,
 991                                       (label_flags & SVf_UTF8)));
 992    }
 993         Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
 994                                              cCOPo->cop_seq);
 995         break;
 996     case OP_ENTERLOOP:
 997         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
 998         if (cLOOPo->op_redoop)
 999             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1000         else
1001             PerlIO_printf(file, "DONE\n");
1002         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1003         if (cLOOPo->op_nextop)
1004             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1005         else
1006             PerlIO_printf(file, "DONE\n");
1007         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1008         if (cLOOPo->op_lastop)
1009             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1010         else
1011             PerlIO_printf(file, "DONE\n");
1012         break;
1013     case OP_COND_EXPR:
1014     case OP_RANGE:
1015     case OP_MAPWHILE:
1016     case OP_GREPWHILE:
1017     case OP_OR:
1018     case OP_AND:
1019         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1020         if (cLOGOPo->op_other)
1021             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1022         else
1023             PerlIO_printf(file, "DONE\n");
1024         break;
1025     case OP_PUSHRE:
1026     case OP_MATCH:
1027     case OP_QR:
1028     case OP_SUBST:
1029         do_pmop_dump(level, file, cPMOPo);
1030         break;
1031     case OP_LEAVE:
1032     case OP_LEAVEEVAL:
1033     case OP_LEAVESUB:
1034     case OP_LEAVESUBLV:
1035     case OP_LEAVEWRITE:
1036     case OP_SCOPE:
1037         if (o->op_private & OPpREFCOUNTED)
1038             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1039         break;
1040     default:
1041         break;
1042     }
1043     if (o->op_flags & OPf_KIDS) {
1044         OP *kid;
1045         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1046             do_op_dump(level, file, kid);
1047     }
1048     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1049 }
1050
1051 /*
1052 =for apidoc op_dump
1053
1054 Dumps the optree starting at OP C<o> to C<STDERR>.
1055
1056 =cut
1057 */
1058
1059 void
1060 Perl_op_dump(pTHX_ const OP *o)
1061 {
1062     PERL_ARGS_ASSERT_OP_DUMP;
1063     do_op_dump(0, Perl_debug_log, o);
1064 }
1065
1066 void
1067 Perl_gv_dump(pTHX_ GV *gv)
1068 {
1069     STRLEN len;
1070     const char* name;
1071     SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1072
1073
1074     PERL_ARGS_ASSERT_GV_DUMP;
1075
1076     if (!gv) {
1077         PerlIO_printf(Perl_debug_log, "{}\n");
1078         return;
1079     }
1080     sv = sv_newmortal();
1081     PerlIO_printf(Perl_debug_log, "{\n");
1082     gv_fullname3(sv, gv, NULL);
1083     name = SvPV_const(sv, len);
1084     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1085                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1086     if (gv != GvEGV(gv)) {
1087         gv_efullname3(sv, GvEGV(gv), NULL);
1088         name = SvPV_const(sv, len);
1089         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1090                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1091     }
1092     PerlIO_putc(Perl_debug_log, '\n');
1093     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1094 }
1095
1096
1097 /* map magic types to the symbolic names
1098  * (with the PERL_MAGIC_ prefixed stripped)
1099  */
1100
1101 static const struct { const char type; const char *name; } magic_names[] = {
1102 #include "mg_names.c"
1103         /* this null string terminates the list */
1104         { 0,                         NULL },
1105 };
1106
1107 void
1108 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1109 {
1110     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1111
1112     for (; mg; mg = mg->mg_moremagic) {
1113         Perl_dump_indent(aTHX_ level, file,
1114                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1115         if (mg->mg_virtual) {
1116             const MGVTBL * const v = mg->mg_virtual;
1117             if (v >= PL_magic_vtables
1118                 && v < PL_magic_vtables + magic_vtable_max) {
1119                 const U32 i = v - PL_magic_vtables;
1120                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1121             }
1122             else
1123                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1124         }
1125         else
1126             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1127
1128         if (mg->mg_private)
1129             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1130
1131         {
1132             int n;
1133             const char *name = NULL;
1134             for (n = 0; magic_names[n].name; n++) {
1135                 if (mg->mg_type == magic_names[n].type) {
1136                     name = magic_names[n].name;
1137                     break;
1138                 }
1139             }
1140             if (name)
1141                 Perl_dump_indent(aTHX_ level, file,
1142                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1143             else
1144                 Perl_dump_indent(aTHX_ level, file,
1145                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1146         }
1147
1148         if (mg->mg_flags) {
1149             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1150             if (mg->mg_type == PERL_MAGIC_envelem &&
1151                 mg->mg_flags & MGf_TAINTEDDIR)
1152                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1153             if (mg->mg_type == PERL_MAGIC_regex_global &&
1154                 mg->mg_flags & MGf_MINMATCH)
1155                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1156             if (mg->mg_flags & MGf_REFCOUNTED)
1157                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1158             if (mg->mg_flags & MGf_GSKIP)
1159                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1160             if (mg->mg_flags & MGf_COPY)
1161                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1162             if (mg->mg_flags & MGf_DUP)
1163                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1164             if (mg->mg_flags & MGf_LOCAL)
1165                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1166             if (mg->mg_type == PERL_MAGIC_regex_global &&
1167                 mg->mg_flags & MGf_BYTES)
1168                 Perl_dump_indent(aTHX_ level, file, "      BYTES\n");
1169         }
1170         if (mg->mg_obj) {
1171             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1172                 PTR2UV(mg->mg_obj));
1173             if (mg->mg_type == PERL_MAGIC_qr) {
1174                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1175                 SV * const dsv = sv_newmortal();
1176                 const char * const s
1177                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1178                     60, NULL, NULL,
1179                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1180                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1181                 );
1182                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1183                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1184                         (IV)RX_REFCNT(re));
1185             }
1186             if (mg->mg_flags & MGf_REFCOUNTED)
1187                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1188         }
1189         if (mg->mg_len)
1190             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1191         if (mg->mg_ptr) {
1192             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1193             if (mg->mg_len >= 0) {
1194                 if (mg->mg_type != PERL_MAGIC_utf8) {
1195                     SV * const sv = newSVpvs("");
1196                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1197                     SvREFCNT_dec_NN(sv);
1198                 }
1199             }
1200             else if (mg->mg_len == HEf_SVKEY) {
1201                 PerlIO_puts(file, " => HEf_SVKEY\n");
1202                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1203                            maxnest, dumpops, pvlim); /* MG is already +1 */
1204                 continue;
1205             }
1206             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1207             else
1208                 PerlIO_puts(
1209                   file,
1210                  " ???? - " __FILE__
1211                  " does not know how to handle this MG_LEN"
1212                 );
1213             PerlIO_putc(file, '\n');
1214         }
1215         if (mg->mg_type == PERL_MAGIC_utf8) {
1216             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1217             if (cache) {
1218                 IV i;
1219                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1220                     Perl_dump_indent(aTHX_ level, file,
1221                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1222                                      i,
1223                                      (UV)cache[i * 2],
1224                                      (UV)cache[i * 2 + 1]);
1225             }
1226         }
1227     }
1228 }
1229
1230 void
1231 Perl_magic_dump(pTHX_ const MAGIC *mg)
1232 {
1233     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1234 }
1235
1236 void
1237 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1238 {
1239     const char *hvname;
1240
1241     PERL_ARGS_ASSERT_DO_HV_DUMP;
1242
1243     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1244     if (sv && (hvname = HvNAME_get(sv)))
1245     {
1246         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1247            name which quite legally could contain insane things like tabs, newlines, nulls or
1248            other scary crap - this should produce sane results - except maybe for unicode package
1249            names - but we will wait for someone to file a bug on that - demerphq */
1250         SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1251         PerlIO_printf(file, "\t\"%s\"\n",
1252                               generic_pv_escape( tmpsv, hvname,
1253                                    HvNAMELEN(sv), HvNAMEUTF8(sv)));
1254     }
1255     else
1256         PerlIO_putc(file, '\n');
1257 }
1258
1259 void
1260 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1261 {
1262     PERL_ARGS_ASSERT_DO_GV_DUMP;
1263
1264     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1265     if (sv && GvNAME(sv)) {
1266         SV * const tmpsv = newSVpvs("");
1267         PerlIO_printf(file, "\t\"%s\"\n",
1268                               generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1269     }
1270     else
1271         PerlIO_putc(file, '\n');
1272 }
1273
1274 void
1275 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1276 {
1277     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1278
1279     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1280     if (sv && GvNAME(sv)) {
1281        SV *tmp = newSVpvs_flags("", SVs_TEMP);
1282         const char *hvname;
1283         HV * const stash = GvSTASH(sv);
1284         PerlIO_printf(file, "\t");
1285    /* TODO might have an extra \" here */
1286         if (stash && (hvname = HvNAME_get(stash))) {
1287             PerlIO_printf(file, "\"%s\" :: \"",
1288                                   generic_pv_escape(tmp, hvname,
1289                                       HvNAMELEN(stash), HvNAMEUTF8(stash)));
1290         }
1291         PerlIO_printf(file, "%s\"\n",
1292                               generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1293     }
1294     else
1295         PerlIO_putc(file, '\n');
1296 }
1297
1298 const struct flag_to_name first_sv_flags_names[] = {
1299     {SVs_TEMP, "TEMP,"},
1300     {SVs_OBJECT, "OBJECT,"},
1301     {SVs_GMG, "GMG,"},
1302     {SVs_SMG, "SMG,"},
1303     {SVs_RMG, "RMG,"},
1304     {SVf_IOK, "IOK,"},
1305     {SVf_NOK, "NOK,"},
1306     {SVf_POK, "POK,"}
1307 };
1308
1309 const struct flag_to_name second_sv_flags_names[] = {
1310     {SVf_OOK, "OOK,"},
1311     {SVf_FAKE, "FAKE,"},
1312     {SVf_READONLY, "READONLY,"},
1313     {SVf_PROTECT, "PROTECT,"},
1314     {SVf_BREAK, "BREAK,"},
1315     {SVp_IOK, "pIOK,"},
1316     {SVp_NOK, "pNOK,"},
1317     {SVp_POK, "pPOK,"}
1318 };
1319
1320 const struct flag_to_name cv_flags_names[] = {
1321     {CVf_ANON, "ANON,"},
1322     {CVf_UNIQUE, "UNIQUE,"},
1323     {CVf_CLONE, "CLONE,"},
1324     {CVf_CLONED, "CLONED,"},
1325     {CVf_CONST, "CONST,"},
1326     {CVf_NODEBUG, "NODEBUG,"},
1327     {CVf_LVALUE, "LVALUE,"},
1328     {CVf_METHOD, "METHOD,"},
1329     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1330     {CVf_CVGV_RC, "CVGV_RC,"},
1331     {CVf_DYNFILE, "DYNFILE,"},
1332     {CVf_AUTOLOAD, "AUTOLOAD,"},
1333     {CVf_HASEVAL, "HASEVAL,"},
1334     {CVf_SLABBED, "SLABBED,"},
1335     {CVf_NAMED, "NAMED,"},
1336     {CVf_LEXICAL, "LEXICAL,"},
1337     {CVf_ISXSUB, "ISXSUB,"}
1338 };
1339
1340 const struct flag_to_name hv_flags_names[] = {
1341     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1342     {SVphv_LAZYDEL, "LAZYDEL,"},
1343     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1344     {SVf_AMAGIC, "OVERLOAD,"},
1345     {SVphv_CLONEABLE, "CLONEABLE,"}
1346 };
1347
1348 const struct flag_to_name gp_flags_names[] = {
1349     {GVf_INTRO, "INTRO,"},
1350     {GVf_MULTI, "MULTI,"},
1351     {GVf_ASSUMECV, "ASSUMECV,"},
1352 };
1353
1354 const struct flag_to_name gp_flags_imported_names[] = {
1355     {GVf_IMPORTED_SV, " SV"},
1356     {GVf_IMPORTED_AV, " AV"},
1357     {GVf_IMPORTED_HV, " HV"},
1358     {GVf_IMPORTED_CV, " CV"},
1359 };
1360
1361 /* NOTE: this structure is mostly duplicative of one generated by
1362  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1363  * the two. - Yves */
1364 const struct flag_to_name regexp_extflags_names[] = {
1365     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1366     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1367     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1368     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1369     {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1370     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1371     {RXf_IS_ANCHORED,     "IS_ANCHORED,"},
1372     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1373     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1374     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1375     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1376     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1377     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1378     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1379     {RXf_SPLIT,           "SPLIT,"},
1380     {RXf_COPY_DONE,       "COPY_DONE,"},
1381     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1382     {RXf_TAINTED,         "TAINTED,"},
1383     {RXf_START_ONLY,      "START_ONLY,"},
1384     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1385     {RXf_WHITE,           "WHITE,"},
1386     {RXf_NULL,            "NULL,"},
1387 };
1388
1389 /* NOTE: this structure is mostly duplicative of one generated by
1390  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1391  * the two. - Yves */
1392 const struct flag_to_name regexp_core_intflags_names[] = {
1393     {PREGf_SKIP,            "SKIP,"},
1394     {PREGf_IMPLICIT,        "IMPLICIT,"},
1395     {PREGf_NAUGHTY,         "NAUGHTY,"},
1396     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1397     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1398     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1399     {PREGf_NOSCAN,          "NOSCAN,"},
1400     {PREGf_CANY_SEEN,       "CANY_SEEN,"},
1401     {PREGf_GPOS_SEEN,       "GPOS_SEEN,"},
1402     {PREGf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1403     {PREGf_ANCH_MBOL,       "ANCH_MBOL,"},
1404     {PREGf_ANCH_SBOL,       "ANCH_SBOL,"},
1405     {PREGf_ANCH_GPOS,       "ANCH_GPOS,"},
1406 };
1407
1408 void
1409 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1410 {
1411     SV *d;
1412     const char *s;
1413     U32 flags;
1414     U32 type;
1415
1416     PERL_ARGS_ASSERT_DO_SV_DUMP;
1417
1418     if (!sv) {
1419         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1420         return;
1421     }
1422
1423     flags = SvFLAGS(sv);
1424     type = SvTYPE(sv);
1425
1426     /* process general SV flags */
1427
1428     d = Perl_newSVpvf(aTHX_
1429                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1430                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1431                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1432                    (int)(PL_dumpindent*level), "");
1433
1434     if (!((flags & SVpad_NAME) == SVpad_NAME
1435           && (type == SVt_PVMG || type == SVt_PVNV))) {
1436         if ((flags & SVs_PADSTALE))
1437             sv_catpv(d, "PADSTALE,");
1438     }
1439     if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1440         if ((flags & SVs_PADTMP))
1441             sv_catpv(d, "PADTMP,");
1442     }
1443     append_flags(d, flags, first_sv_flags_names);
1444     if (flags & SVf_ROK)  {
1445                                 sv_catpv(d, "ROK,");
1446         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1447     }
1448     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1449     append_flags(d, flags, second_sv_flags_names);
1450     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1451                            && type != SVt_PVAV) {
1452         if (SvPCS_IMPORTED(sv))
1453                                 sv_catpv(d, "PCS_IMPORTED,");
1454         else
1455                                 sv_catpv(d, "SCREAM,");
1456     }
1457
1458     /* process type-specific SV flags */
1459
1460     switch (type) {
1461     case SVt_PVCV:
1462     case SVt_PVFM:
1463         append_flags(d, CvFLAGS(sv), cv_flags_names);
1464         break;
1465     case SVt_PVHV:
1466         append_flags(d, flags, hv_flags_names);
1467         break;
1468     case SVt_PVGV:
1469     case SVt_PVLV:
1470         if (isGV_with_GP(sv)) {
1471             append_flags(d, GvFLAGS(sv), gp_flags_names);
1472         }
1473         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1474             sv_catpv(d, "IMPORT");
1475             if (GvIMPORTED(sv) == GVf_IMPORTED)
1476                 sv_catpv(d, "ALL,");
1477             else {
1478                 sv_catpv(d, "(");
1479                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1480                 sv_catpv(d, " ),");
1481             }
1482         }
1483         /* FALLTHROUGH */
1484     default:
1485     evaled_or_uv:
1486         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1487         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1488         break;
1489     case SVt_PVMG:
1490         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1491         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1492         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1493         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1494         /* FALLTHROUGH */
1495     case SVt_PVNV:
1496         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1497         goto evaled_or_uv;
1498     case SVt_PVAV:
1499         break;
1500     }
1501     /* SVphv_SHAREKEYS is also 0x20000000 */
1502     if ((type != SVt_PVHV) && SvUTF8(sv))
1503         sv_catpv(d, "UTF8");
1504
1505     if (*(SvEND(d) - 1) == ',') {
1506         SvCUR_set(d, SvCUR(d) - 1);
1507         SvPVX(d)[SvCUR(d)] = '\0';
1508     }
1509     sv_catpv(d, ")");
1510     s = SvPVX_const(d);
1511
1512     /* dump initial SV details */
1513
1514 #ifdef DEBUG_LEAKING_SCALARS
1515     Perl_dump_indent(aTHX_ level, file,
1516         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1517         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1518         sv->sv_debug_line,
1519         sv->sv_debug_inpad ? "for" : "by",
1520         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1521         PTR2UV(sv->sv_debug_parent),
1522         sv->sv_debug_serial
1523     );
1524 #endif
1525     Perl_dump_indent(aTHX_ level, file, "SV = ");
1526
1527     /* Dump SV type */
1528
1529     if (type < SVt_LAST) {
1530         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1531
1532         if (type ==  SVt_NULL) {
1533             SvREFCNT_dec_NN(d);
1534             return;
1535         }
1536     } else {
1537         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1538         SvREFCNT_dec_NN(d);
1539         return;
1540     }
1541
1542     /* Dump general SV fields */
1543
1544     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1545          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1546          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1547         || (type == SVt_IV && !SvROK(sv))) {
1548         if (SvIsUV(sv)
1549 #ifdef PERL_OLD_COPY_ON_WRITE
1550                        || SvIsCOW(sv)
1551 #endif
1552                                      )
1553             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1554         else
1555             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1556 #ifdef PERL_OLD_COPY_ON_WRITE
1557         if (SvIsCOW_shared_hash(sv))
1558             PerlIO_printf(file, "  (HASH)");
1559         else if (SvIsCOW_normal(sv))
1560             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1561 #endif
1562         PerlIO_putc(file, '\n');
1563     }
1564
1565     if ((type == SVt_PVNV || type == SVt_PVMG)
1566         && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1567         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1568                          (UV) COP_SEQ_RANGE_LOW(sv));
1569         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1570                          (UV) COP_SEQ_RANGE_HIGH(sv));
1571     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1572                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1573                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1574                || type == SVt_NV) {
1575         STORE_NUMERIC_LOCAL_SET_STANDARD();
1576         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1577         RESTORE_NUMERIC_LOCAL();
1578     }
1579
1580     if (SvROK(sv)) {
1581         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1582         if (nest < maxnest)
1583             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1584     }
1585
1586     if (type < SVt_PV) {
1587         SvREFCNT_dec_NN(d);
1588         return;
1589     }
1590
1591     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1592      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1593         const bool re = isREGEXP(sv);
1594         const char * const ptr =
1595             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1596         if (ptr) {
1597             STRLEN delta;
1598             if (SvOOK(sv)) {
1599                 SvOOK_offset(sv, delta);
1600                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1601                                  (UV) delta);
1602             } else {
1603                 delta = 0;
1604             }
1605             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(ptr));
1606             if (SvOOK(sv)) {
1607                 PerlIO_printf(file, "( %s . ) ",
1608                               pv_display(d, ptr - delta, delta, 0,
1609                                          pvlim));
1610             }
1611             if (type == SVt_INVLIST) {
1612                 PerlIO_printf(file, "\n");
1613                 /* 4 blanks indents 2 beyond the PV, etc */
1614                 _invlist_dump(file, level, "    ", sv);
1615             }
1616             else {
1617                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1618                                                      re ? 0 : SvLEN(sv),
1619                                                      pvlim));
1620                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1621                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1622                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1623                                                         UNI_DISPLAY_QQ));
1624                 PerlIO_printf(file, "\n");
1625             }
1626             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1627             if (!re)
1628                 Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
1629                                        (IV)SvLEN(sv));
1630 #ifdef PERL_NEW_COPY_ON_WRITE
1631             if (SvIsCOW(sv) && SvLEN(sv))
1632                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1633                                        CowREFCNT(sv));
1634 #endif
1635         }
1636         else
1637             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1638     }
1639
1640     if (type >= SVt_PVMG) {
1641         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1642             HV * const ost = SvOURSTASH(sv);
1643             if (ost)
1644                 do_hv_dump(level, file, "  OURSTASH", ost);
1645         } else {
1646             if (SvMAGIC(sv))
1647                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1648         }
1649         if (SvSTASH(sv))
1650             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1651
1652         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1653             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1654         }
1655     }
1656
1657     /* Dump type-specific SV fields */
1658
1659     switch (type) {
1660     case SVt_PVAV:
1661         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1662         if (AvARRAY(sv) != AvALLOC(sv)) {
1663             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1664             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1665         }
1666         else
1667             PerlIO_putc(file, '\n');
1668         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1669         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1670         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n",
1671                                    SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1672         sv_setpvs(d, "");
1673         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1674         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1675         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1676                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1677         if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1678             SSize_t count;
1679             for (count = 0; count <=  av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1680                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1681
1682                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1683                 if (elt)
1684                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1685             }
1686         }
1687         break;
1688     case SVt_PVHV: {
1689         U32 usedkeys;
1690         if (SvOOK(sv)) {
1691             struct xpvhv_aux *const aux = HvAUX(sv);
1692             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %"UVuf"\n",
1693                              (UV)aux->xhv_aux_flags);
1694         }
1695         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1696         usedkeys = HvUSEDKEYS(sv);
1697         if (HvARRAY(sv) && usedkeys) {
1698             /* Show distribution of HEs in the ARRAY */
1699             int freq[200];
1700 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1701             int i;
1702             int max = 0;
1703             U32 pow2 = 2, keys = usedkeys;
1704             NV theoret, sum = 0;
1705
1706             PerlIO_printf(file, "  (");
1707             Zero(freq, FREQ_MAX + 1, int);
1708             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1709                 HE* h;
1710                 int count = 0;
1711                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1712                     count++;
1713                 if (count > FREQ_MAX)
1714                     count = FREQ_MAX;
1715                 freq[count]++;
1716                 if (max < count)
1717                     max = count;
1718             }
1719             for (i = 0; i <= max; i++) {
1720                 if (freq[i]) {
1721                     PerlIO_printf(file, "%d%s:%d", i,
1722                                   (i == FREQ_MAX) ? "+" : "",
1723                                   freq[i]);
1724                     if (i != max)
1725                         PerlIO_printf(file, ", ");
1726                 }
1727             }
1728             PerlIO_putc(file, ')');
1729             /* The "quality" of a hash is defined as the total number of
1730                comparisons needed to access every element once, relative
1731                to the expected number needed for a random hash.
1732
1733                The total number of comparisons is equal to the sum of
1734                the squares of the number of entries in each bucket.
1735                For a random hash of n keys into k buckets, the expected
1736                value is
1737                                 n + n(n-1)/2k
1738             */
1739
1740             for (i = max; i > 0; i--) { /* Precision: count down. */
1741                 sum += freq[i] * i * i;
1742             }
1743             while ((keys = keys >> 1))
1744                 pow2 = pow2 << 1;
1745             theoret = usedkeys;
1746             theoret += theoret * (theoret-1)/pow2;
1747             PerlIO_putc(file, '\n');
1748             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1749         }
1750         PerlIO_putc(file, '\n');
1751         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)usedkeys);
1752         {
1753             STRLEN count = 0;
1754             HE **ents = HvARRAY(sv);
1755
1756             if (ents) {
1757                 HE *const *const last = ents + HvMAX(sv);
1758                 count = last + 1 - ents;
1759
1760                 do {
1761                     if (!*ents)
1762                         --count;
1763                 } while (++ents <= last);
1764             }
1765
1766             if (SvOOK(sv)) {
1767                 struct xpvhv_aux *const aux = HvAUX(sv);
1768                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf
1769                                  " (cached = %"UVuf")\n",
1770                                  (UV)count, (UV)aux->xhv_fill_lazy);
1771             } else {
1772                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
1773                                  (UV)count);
1774             }
1775         }
1776         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1777         if (SvOOK(sv)) {
1778             Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1779             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1780 #ifdef PERL_HASH_RANDOMIZE_KEYS
1781             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1782             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1783                 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1784             }
1785 #endif
1786             PerlIO_putc(file, '\n');
1787         }
1788         {
1789             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1790             if (mg && mg->mg_obj) {
1791                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1792             }
1793         }
1794         {
1795             const char * const hvname = HvNAME_get(sv);
1796             if (hvname) {
1797           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1798      Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1799                                        generic_pv_escape( tmpsv, hvname,
1800                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
1801         }
1802         }
1803         if (SvOOK(sv)) {
1804             AV * const backrefs
1805                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1806             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1807             if (HvAUX(sv)->xhv_name_count)
1808                 Perl_dump_indent(aTHX_
1809                  level, file, "  NAMECOUNT = %"IVdf"\n",
1810                  (IV)HvAUX(sv)->xhv_name_count
1811                 );
1812             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1813                 const I32 count = HvAUX(sv)->xhv_name_count;
1814                 if (count) {
1815                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1816                     /* The starting point is the first element if count is
1817                        positive and the second element if count is negative. */
1818                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1819                         + (count < 0 ? 1 : 0);
1820                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1821                         + (count < 0 ? -count : count);
1822                     while (hekp < endp) {
1823                         if (HEK_LEN(*hekp)) {
1824              SV *tmp = newSVpvs_flags("", SVs_TEMP);
1825                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1826                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1827                         } else {
1828                             /* This should never happen. */
1829                             sv_catpvs(names, ", (null)");
1830                         }
1831                         ++hekp;
1832                     }
1833                     Perl_dump_indent(aTHX_
1834                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1835                     );
1836                 }
1837                 else {
1838                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1839                     const char *const hvename = HvENAME_get(sv);
1840                     Perl_dump_indent(aTHX_
1841                      level, file, "  ENAME = \"%s\"\n",
1842                      generic_pv_escape(tmp, hvename,
1843                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1844                 }
1845             }
1846             if (backrefs) {
1847                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1848                                  PTR2UV(backrefs));
1849                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1850                            dumpops, pvlim);
1851             }
1852             if (meta) {
1853                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1854                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1855                                  generic_pv_escape( tmpsv, meta->mro_which->name,
1856                                 meta->mro_which->length,
1857                                 (meta->mro_which->kflags & HVhek_UTF8)),
1858                                  PTR2UV(meta->mro_which));
1859                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1860                                  (UV)meta->cache_gen);
1861                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1862                                  (UV)meta->pkg_gen);
1863                 if (meta->mro_linear_all) {
1864                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1865                                  PTR2UV(meta->mro_linear_all));
1866                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1867                            dumpops, pvlim);
1868                 }
1869                 if (meta->mro_linear_current) {
1870                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1871                                  PTR2UV(meta->mro_linear_current));
1872                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1873                            dumpops, pvlim);
1874                 }
1875                 if (meta->mro_nextmethod) {
1876                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1877                                  PTR2UV(meta->mro_nextmethod));
1878                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1879                            dumpops, pvlim);
1880                 }
1881                 if (meta->isa) {
1882                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1883                                  PTR2UV(meta->isa));
1884                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1885                            dumpops, pvlim);
1886                 }
1887             }
1888         }
1889         if (nest < maxnest) {
1890             HV * const hv = MUTABLE_HV(sv);
1891             STRLEN i;
1892             HE *he;
1893
1894             if (HvARRAY(hv)) {
1895                 int count = maxnest - nest;
1896                 for (i=0; i <= HvMAX(hv); i++) {
1897                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1898                         U32 hash;
1899                         SV * keysv;
1900                         const char * keypv;
1901                         SV * elt;
1902                         STRLEN len;
1903
1904                         if (count-- <= 0) goto DONEHV;
1905
1906                         hash = HeHASH(he);
1907                         keysv = hv_iterkeysv(he);
1908                         keypv = SvPV_const(keysv, len);
1909                         elt = HeVAL(he);
1910
1911                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1912                         if (SvUTF8(keysv))
1913                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1914                         if (HvEITER_get(hv) == he)
1915                             PerlIO_printf(file, "[CURRENT] ");
1916                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1917                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1918                     }
1919                 }
1920               DONEHV:;
1921             }
1922         }
1923         break;
1924     } /* case SVt_PVHV */
1925
1926     case SVt_PVCV:
1927         if (CvAUTOLOAD(sv)) {
1928             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1929        STRLEN len;
1930             const char *const name =  SvPV_const(sv, len);
1931             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
1932                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1933         }
1934         if (SvPOK(sv)) {
1935        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1936        const char *const proto = CvPROTO(sv);
1937             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
1938                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1939                                 SvUTF8(sv)));
1940         }
1941         /* FALLTHROUGH */
1942     case SVt_PVFM:
1943         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1944         if (!CvISXSUB(sv)) {
1945             if (CvSTART(sv)) {
1946                 Perl_dump_indent(aTHX_ level, file,
1947                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1948                                  PTR2UV(CvSTART(sv)),
1949                                  (IV)sequence_num(CvSTART(sv)));
1950             }
1951             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1952                              PTR2UV(CvROOT(sv)));
1953             if (CvROOT(sv) && dumpops) {
1954                 do_op_dump(level+1, file, CvROOT(sv));
1955             }
1956         } else {
1957             SV * const constant = cv_const_sv((const CV *)sv);
1958
1959             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1960
1961             if (constant) {
1962                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1963                                  " (CONST SV)\n",
1964                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1965                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1966                            pvlim);
1967             } else {
1968                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1969                                  (IV)CvXSUBANY(sv).any_i32);
1970             }
1971         }
1972         if (CvNAMED(sv))
1973             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1974                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
1975         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1976         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1977         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1978         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1979         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1980         if (!CvISXSUB(sv)) {
1981             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1982             if (nest < maxnest) {
1983                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1984             }
1985         }
1986         else
1987             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
1988         {
1989             const CV * const outside = CvOUTSIDE(sv);
1990             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1991                         PTR2UV(outside),
1992                         (!outside ? "null"
1993                          : CvANON(outside) ? "ANON"
1994                          : (outside == PL_main_cv) ? "MAIN"
1995                          : CvUNIQUE(outside) ? "UNIQUE"
1996                          : CvGV(outside) ?
1997                              generic_pv_escape(
1998                                  newSVpvs_flags("", SVs_TEMP),
1999                                  GvNAME(CvGV(outside)),
2000                                  GvNAMELEN(CvGV(outside)),
2001                                  GvNAMEUTF8(CvGV(outside)))
2002                          : "UNDEFINED"));
2003         }
2004         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2005             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2006         break;
2007
2008     case SVt_PVGV:
2009     case SVt_PVLV:
2010         if (type == SVt_PVLV) {
2011             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2012             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2013             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2014             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2015             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2016             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2017                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2018                     dumpops, pvlim);
2019         }
2020         if (isREGEXP(sv)) goto dumpregexp;
2021         if (!isGV_with_GP(sv))
2022             break;
2023        {
2024           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2025           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2026                     generic_pv_escape(tmpsv, GvNAME(sv),
2027                                       GvNAMELEN(sv),
2028                                       GvNAMEUTF8(sv)));
2029        }
2030         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2031         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2032         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2033         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2034         if (!GvGP(sv))
2035             break;
2036         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2037         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2038         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2039         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2040         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2041         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2042         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2043         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2044         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%"UVxf
2045                                             " (%s)\n",
2046                                (UV)GvGPFLAGS(sv),
2047                                GvALIASED_SV(sv) ? "ALIASED_SV" : "");
2048         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2049         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2050         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2051         break;
2052     case SVt_PVIO:
2053         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2054         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2055         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2056         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2057         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2058         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2059         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2060         if (IoTOP_NAME(sv))
2061             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2062         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2063             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2064         else {
2065             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2066                              PTR2UV(IoTOP_GV(sv)));
2067             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2068                         maxnest, dumpops, pvlim);
2069         }
2070         /* Source filters hide things that are not GVs in these three, so let's
2071            be careful out there.  */
2072         if (IoFMT_NAME(sv))
2073             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2074         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2075             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2076         else {
2077             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2078                              PTR2UV(IoFMT_GV(sv)));
2079             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2080                         maxnest, dumpops, pvlim);
2081         }
2082         if (IoBOTTOM_NAME(sv))
2083             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2084         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2085             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2086         else {
2087             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2088                              PTR2UV(IoBOTTOM_GV(sv)));
2089             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2090                         maxnest, dumpops, pvlim);
2091         }
2092         if (isPRINT(IoTYPE(sv)))
2093             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2094         else
2095             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2096         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2097         break;
2098     case SVt_REGEXP:
2099       dumpregexp:
2100         {
2101             struct regexp * const r = ReANY((REGEXP*)sv);
2102
2103 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2104             sv_setpv(d,"");                                 \
2105             append_flags(d, flags, names);     \
2106             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2107                 SvCUR_set(d, SvCUR(d) - 1);                 \
2108                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2109             }                                               \
2110 } STMT_END
2111             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2112             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
2113                                 (UV)(r->compflags), SvPVX_const(d));
2114
2115             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2116             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2117                                 (UV)(r->extflags), SvPVX_const(d));
2118
2119             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf" (%s)\n",
2120                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2121             if (r->engine == &PL_core_reg_engine) {
2122                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2123                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf" (%s)\n",
2124                                 (UV)(r->intflags), SvPVX_const(d));
2125             } else {
2126                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2127                                 (UV)(r->intflags));
2128             }
2129 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2130             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2131                                 (UV)(r->nparens));
2132             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2133                                 (UV)(r->lastparen));
2134             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2135                                 (UV)(r->lastcloseparen));
2136             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2137                                 (IV)(r->minlen));
2138             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2139                                 (IV)(r->minlenret));
2140             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2141                                 (UV)(r->gofs));
2142             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2143                                 (UV)(r->pre_prefix));
2144             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2145                                 (IV)(r->sublen));
2146             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
2147                                 (IV)(r->suboffset));
2148             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
2149                                 (IV)(r->subcoffset));
2150             if (r->subbeg)
2151                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2152                             PTR2UV(r->subbeg),
2153                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2154             else
2155                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2156             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2157                                 PTR2UV(r->mother_re));
2158             if (nest < maxnest && r->mother_re)
2159                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2160                            maxnest, dumpops, pvlim);
2161             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2162                                 PTR2UV(r->paren_names));
2163             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2164                                 PTR2UV(r->substrs));
2165             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2166                                 PTR2UV(r->pprivate));
2167             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2168                                 PTR2UV(r->offs));
2169             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2170                                 PTR2UV(r->qr_anoncv));
2171 #ifdef PERL_ANY_COW
2172             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2173                                 PTR2UV(r->saved_copy));
2174 #endif
2175         }
2176         break;
2177     }
2178     SvREFCNT_dec_NN(d);
2179 }
2180
2181 /*
2182 =for apidoc sv_dump
2183
2184 Dumps the contents of an SV to the C<STDERR> filehandle.
2185
2186 For an example of its output, see L<Devel::Peek>.
2187
2188 =cut
2189 */
2190
2191 void
2192 Perl_sv_dump(pTHX_ SV *sv)
2193 {
2194     PERL_ARGS_ASSERT_SV_DUMP;
2195
2196     if (SvROK(sv))
2197         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2198     else
2199         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2200 }
2201
2202 int
2203 Perl_runops_debug(pTHX)
2204 {
2205     if (!PL_op) {
2206         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2207         return 0;
2208     }
2209
2210     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2211     do {
2212 #ifdef PERL_TRACE_OPS
2213         ++PL_op_exec_cnt[PL_op->op_type];
2214 #endif
2215         if (PL_debug) {
2216             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2217                 PerlIO_printf(Perl_debug_log,
2218                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2219                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2220                               PTR2UV(*PL_watchaddr));
2221             if (DEBUG_s_TEST_) {
2222                 if (DEBUG_v_TEST_) {
2223                     PerlIO_printf(Perl_debug_log, "\n");
2224                     deb_stack_all();
2225                 }
2226                 else
2227                     debstack();
2228             }
2229
2230
2231             if (DEBUG_t_TEST_) debop(PL_op);
2232             if (DEBUG_P_TEST_) debprof(PL_op);
2233         }
2234
2235         OP_ENTRY_PROBE(OP_NAME(PL_op));
2236     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2237     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2238     PERL_ASYNC_CHECK();
2239
2240     TAINT_NOT;
2241     return 0;
2242 }
2243
2244 I32
2245 Perl_debop(pTHX_ const OP *o)
2246 {
2247     int count;
2248
2249     PERL_ARGS_ASSERT_DEBOP;
2250
2251     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2252         return 0;
2253
2254     Perl_deb(aTHX_ "%s", OP_NAME(o));
2255     switch (o->op_type) {
2256     case OP_CONST:
2257     case OP_HINTSEVAL:
2258         /* With ITHREADS, consts are stored in the pad, and the right pad
2259          * may not be active here, so check.
2260          * Looks like only during compiling the pads are illegal.
2261          */
2262 #ifdef USE_ITHREADS
2263         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2264 #endif
2265             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2266         break;
2267     case OP_GVSV:
2268     case OP_GV:
2269         if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2270             SV * const sv = newSV(0);
2271             gv_fullname3(sv, cGVOPo_gv, NULL);
2272             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2273             SvREFCNT_dec_NN(sv);
2274         }
2275         else if (cGVOPo_gv) {
2276             SV * const sv = newSV(0);
2277             assert(SvROK(cGVOPo_gv));
2278             assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2279             PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2280                     SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2281             SvREFCNT_dec_NN(sv);
2282         }
2283         else
2284             PerlIO_printf(Perl_debug_log, "(NULL)");
2285         break;
2286
2287     case OP_PADSV:
2288     case OP_PADAV:
2289     case OP_PADHV:
2290         count = 1;
2291         goto dump_padop;
2292     case OP_PADRANGE:
2293         count = o->op_private & OPpPADRANGE_COUNTMASK;
2294     dump_padop:
2295         /* print the lexical's name */
2296         {
2297             CV * const cv = deb_curcv(cxstack_ix);
2298             PADNAME *sv;
2299             PADNAMELIST * comppad = NULL;
2300             int i;
2301
2302             if (cv) {
2303                 PADLIST * const padlist = CvPADLIST(cv);
2304                 comppad = PadlistNAMES(padlist);
2305             }
2306             PerlIO_printf(Perl_debug_log, "(");
2307             for (i = 0; i < count; i++) {
2308                 if (comppad &&
2309                         (sv = padnamelist_fetch(comppad, o->op_targ + i)))
2310                     PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2311                 else
2312                     PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2313                             (UV)o->op_targ+i);
2314                 if (i < count-1)
2315                     PerlIO_printf(Perl_debug_log, ",");
2316             }
2317             PerlIO_printf(Perl_debug_log, ")");
2318         }
2319         break;
2320
2321     default:
2322         break;
2323     }
2324     PerlIO_printf(Perl_debug_log, "\n");
2325     return 0;
2326 }
2327
2328 STATIC CV*
2329 S_deb_curcv(pTHX_ const I32 ix)
2330 {
2331     const PERL_CONTEXT * const cx = &cxstack[ix];
2332     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2333         return cx->blk_sub.cv;
2334     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2335         return cx->blk_eval.cv;
2336     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2337         return PL_main_cv;
2338     else if (ix <= 0)
2339         return NULL;
2340     else
2341         return deb_curcv(ix - 1);
2342 }
2343
2344 void
2345 Perl_watch(pTHX_ char **addr)
2346 {
2347     PERL_ARGS_ASSERT_WATCH;
2348
2349     PL_watchaddr = addr;
2350     PL_watchok = *addr;
2351     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2352         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2353 }
2354
2355 STATIC void
2356 S_debprof(pTHX_ const OP *o)
2357 {
2358     PERL_ARGS_ASSERT_DEBPROF;
2359
2360     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2361         return;
2362     if (!PL_profiledata)
2363         Newxz(PL_profiledata, MAXO, U32);
2364     ++PL_profiledata[o->op_type];
2365 }
2366
2367 void
2368 Perl_debprofdump(pTHX)
2369 {
2370     unsigned i;
2371     if (!PL_profiledata)
2372         return;
2373     for (i = 0; i < MAXO; i++) {
2374         if (PL_profiledata[i])
2375             PerlIO_printf(Perl_debug_log,
2376                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2377                                        PL_op_name[i]);
2378     }
2379 }
2380
2381
2382 /*
2383  * Local variables:
2384  * c-indentation-style: bsd
2385  * c-basic-offset: 4
2386  * indent-tabs-mode: nil
2387  * End:
2388  *
2389  * ex: set ts=8 sts=4 sw=4 et:
2390  */