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 #ifndef USE_ITHREADS
 959         /* with ITHREADS, consts are stored in the pad, and the right pad
 960          * may not be active here, so skip */
 961         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
 962 #endif
 963         break;
 964     case OP_NULL:
 965         if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
 966             break;
 967         /* FALLTHROUGH */
 968     case OP_NEXTSTATE:
 969     case OP_DBSTATE:
 970         if (CopLINE(cCOPo))
 971             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
 972                              (UV)CopLINE(cCOPo));
 973     if (CopSTASHPV(cCOPo)) {
 974         SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
 975         HV *stash = CopSTASH(cCOPo);
 976         const char * const hvname = HvNAME_get(stash);
 977
 978             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
 979                            generic_pv_escape(tmpsv, hvname,
 980                               HvNAMELEN(stash), HvNAMEUTF8(stash)));
 981     }
 982   if (CopLABEL(cCOPo)) {
 983        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
 984        STRLEN label_len;
 985        U32 label_flags;
 986        const char *label = CopLABEL_len_flags(cCOPo,
 987                                                 &label_len, &label_flags);
 988        Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
 989                            generic_pv_escape( tmpsv, label, label_len,
 990                                       (label_flags & SVf_UTF8)));
 991    }
 992         Perl_dump_indent(aTHX_ level, file, "SEQ = %d\n",
 993                                              cCOPo->cop_seq);
 994         break;
 995     case OP_ENTERLOOP:
 996         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
 997         if (cLOOPo->op_redoop)
 998             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
 999         else
1000             PerlIO_printf(file, "DONE\n");
1001         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1002         if (cLOOPo->op_nextop)
1003             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1004         else
1005             PerlIO_printf(file, "DONE\n");
1006         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1007         if (cLOOPo->op_lastop)
1008             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1009         else
1010             PerlIO_printf(file, "DONE\n");
1011         break;
1012     case OP_COND_EXPR:
1013     case OP_RANGE:
1014     case OP_MAPWHILE:
1015     case OP_GREPWHILE:
1016     case OP_OR:
1017     case OP_AND:
1018         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1019         if (cLOGOPo->op_other)
1020             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1021         else
1022             PerlIO_printf(file, "DONE\n");
1023         break;
1024     case OP_PUSHRE:
1025     case OP_MATCH:
1026     case OP_QR:
1027     case OP_SUBST:
1028         do_pmop_dump(level, file, cPMOPo);
1029         break;
1030     case OP_LEAVE:
1031     case OP_LEAVEEVAL:
1032     case OP_LEAVESUB:
1033     case OP_LEAVESUBLV:
1034     case OP_LEAVEWRITE:
1035     case OP_SCOPE:
1036         if (o->op_private & OPpREFCOUNTED)
1037             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1038         break;
1039     default:
1040         break;
1041     }
1042     if (o->op_flags & OPf_KIDS) {
1043         OP *kid;
1044         for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(kid))
1045             do_op_dump(level, file, kid);
1046     }
1047     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1048 }
1049
1050 /*
1051 =for apidoc op_dump
1052
1053 Dumps the optree starting at OP C<o> to C<STDERR>.
1054
1055 =cut
1056 */
1057
1058 void
1059 Perl_op_dump(pTHX_ const OP *o)
1060 {
1061     PERL_ARGS_ASSERT_OP_DUMP;
1062     do_op_dump(0, Perl_debug_log, o);
1063 }
1064
1065 void
1066 Perl_gv_dump(pTHX_ GV *gv)
1067 {
1068     STRLEN len;
1069     const char* name;
1070     SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1071
1072
1073     PERL_ARGS_ASSERT_GV_DUMP;
1074
1075     if (!gv) {
1076         PerlIO_printf(Perl_debug_log, "{}\n");
1077         return;
1078     }
1079     sv = sv_newmortal();
1080     PerlIO_printf(Perl_debug_log, "{\n");
1081     gv_fullname3(sv, gv, NULL);
1082     name = SvPV_const(sv, len);
1083     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1084                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1085     if (gv != GvEGV(gv)) {
1086         gv_efullname3(sv, GvEGV(gv), NULL);
1087         name = SvPV_const(sv, len);
1088         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1089                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1090     }
1091     PerlIO_putc(Perl_debug_log, '\n');
1092     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1093 }
1094
1095
1096 /* map magic types to the symbolic names
1097  * (with the PERL_MAGIC_ prefixed stripped)
1098  */
1099
1100 static const struct { const char type; const char *name; } magic_names[] = {
1101 #include "mg_names.c"
1102         /* this null string terminates the list */
1103         { 0,                         NULL },
1104 };
1105
1106 void
1107 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1108 {
1109     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1110
1111     for (; mg; mg = mg->mg_moremagic) {
1112         Perl_dump_indent(aTHX_ level, file,
1113                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1114         if (mg->mg_virtual) {
1115             const MGVTBL * const v = mg->mg_virtual;
1116             if (v >= PL_magic_vtables
1117                 && v < PL_magic_vtables + magic_vtable_max) {
1118                 const U32 i = v - PL_magic_vtables;
1119                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1120             }
1121             else
1122                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1123         }
1124         else
1125             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1126
1127         if (mg->mg_private)
1128             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1129
1130         {
1131             int n;
1132             const char *name = NULL;
1133             for (n = 0; magic_names[n].name; n++) {
1134                 if (mg->mg_type == magic_names[n].type) {
1135                     name = magic_names[n].name;
1136                     break;
1137                 }
1138             }
1139             if (name)
1140                 Perl_dump_indent(aTHX_ level, file,
1141                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1142             else
1143                 Perl_dump_indent(aTHX_ level, file,
1144                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1145         }
1146
1147         if (mg->mg_flags) {
1148             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1149             if (mg->mg_type == PERL_MAGIC_envelem &&
1150                 mg->mg_flags & MGf_TAINTEDDIR)
1151                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1152             if (mg->mg_type == PERL_MAGIC_regex_global &&
1153                 mg->mg_flags & MGf_MINMATCH)
1154                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1155             if (mg->mg_flags & MGf_REFCOUNTED)
1156                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1157             if (mg->mg_flags & MGf_GSKIP)
1158                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1159             if (mg->mg_flags & MGf_COPY)
1160                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1161             if (mg->mg_flags & MGf_DUP)
1162                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1163             if (mg->mg_flags & MGf_LOCAL)
1164                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1165             if (mg->mg_type == PERL_MAGIC_regex_global &&
1166                 mg->mg_flags & MGf_BYTES)
1167                 Perl_dump_indent(aTHX_ level, file, "      BYTES\n");
1168         }
1169         if (mg->mg_obj) {
1170             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1171                 PTR2UV(mg->mg_obj));
1172             if (mg->mg_type == PERL_MAGIC_qr) {
1173                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1174                 SV * const dsv = sv_newmortal();
1175                 const char * const s
1176                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1177                     60, NULL, NULL,
1178                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1179                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1180                 );
1181                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1182                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1183                         (IV)RX_REFCNT(re));
1184             }
1185             if (mg->mg_flags & MGf_REFCOUNTED)
1186                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1187         }
1188         if (mg->mg_len)
1189             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1190         if (mg->mg_ptr) {
1191             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1192             if (mg->mg_len >= 0) {
1193                 if (mg->mg_type != PERL_MAGIC_utf8) {
1194                     SV * const sv = newSVpvs("");
1195                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1196                     SvREFCNT_dec_NN(sv);
1197                 }
1198             }
1199             else if (mg->mg_len == HEf_SVKEY) {
1200                 PerlIO_puts(file, " => HEf_SVKEY\n");
1201                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1202                            maxnest, dumpops, pvlim); /* MG is already +1 */
1203                 continue;
1204             }
1205             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1206             else
1207                 PerlIO_puts(
1208                   file,
1209                  " ???? - " __FILE__
1210                  " does not know how to handle this MG_LEN"
1211                 );
1212             PerlIO_putc(file, '\n');
1213         }
1214         if (mg->mg_type == PERL_MAGIC_utf8) {
1215             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1216             if (cache) {
1217                 IV i;
1218                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1219                     Perl_dump_indent(aTHX_ level, file,
1220                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1221                                      i,
1222                                      (UV)cache[i * 2],
1223                                      (UV)cache[i * 2 + 1]);
1224             }
1225         }
1226     }
1227 }
1228
1229 void
1230 Perl_magic_dump(pTHX_ const MAGIC *mg)
1231 {
1232     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1233 }
1234
1235 void
1236 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1237 {
1238     const char *hvname;
1239
1240     PERL_ARGS_ASSERT_DO_HV_DUMP;
1241
1242     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1243     if (sv && (hvname = HvNAME_get(sv)))
1244     {
1245         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1246            name which quite legally could contain insane things like tabs, newlines, nulls or
1247            other scary crap - this should produce sane results - except maybe for unicode package
1248            names - but we will wait for someone to file a bug on that - demerphq */
1249         SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1250         PerlIO_printf(file, "\t\"%s\"\n",
1251                               generic_pv_escape( tmpsv, hvname,
1252                                    HvNAMELEN(sv), HvNAMEUTF8(sv)));
1253     }
1254     else
1255         PerlIO_putc(file, '\n');
1256 }
1257
1258 void
1259 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1260 {
1261     PERL_ARGS_ASSERT_DO_GV_DUMP;
1262
1263     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1264     if (sv && GvNAME(sv)) {
1265         SV * const tmpsv = newSVpvs("");
1266         PerlIO_printf(file, "\t\"%s\"\n",
1267                               generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1268     }
1269     else
1270         PerlIO_putc(file, '\n');
1271 }
1272
1273 void
1274 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1275 {
1276     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1277
1278     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1279     if (sv && GvNAME(sv)) {
1280        SV *tmp = newSVpvs_flags("", SVs_TEMP);
1281         const char *hvname;
1282         HV * const stash = GvSTASH(sv);
1283         PerlIO_printf(file, "\t");
1284    /* TODO might have an extra \" here */
1285         if (stash && (hvname = HvNAME_get(stash))) {
1286             PerlIO_printf(file, "\"%s\" :: \"",
1287                                   generic_pv_escape(tmp, hvname,
1288                                       HvNAMELEN(stash), HvNAMEUTF8(stash)));
1289         }
1290         PerlIO_printf(file, "%s\"\n",
1291                               generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1292     }
1293     else
1294         PerlIO_putc(file, '\n');
1295 }
1296
1297 const struct flag_to_name first_sv_flags_names[] = {
1298     {SVs_TEMP, "TEMP,"},
1299     {SVs_OBJECT, "OBJECT,"},
1300     {SVs_GMG, "GMG,"},
1301     {SVs_SMG, "SMG,"},
1302     {SVs_RMG, "RMG,"},
1303     {SVf_IOK, "IOK,"},
1304     {SVf_NOK, "NOK,"},
1305     {SVf_POK, "POK,"}
1306 };
1307
1308 const struct flag_to_name second_sv_flags_names[] = {
1309     {SVf_OOK, "OOK,"},
1310     {SVf_FAKE, "FAKE,"},
1311     {SVf_READONLY, "READONLY,"},
1312     {SVf_PROTECT, "PROTECT,"},
1313     {SVf_BREAK, "BREAK,"},
1314     {SVp_IOK, "pIOK,"},
1315     {SVp_NOK, "pNOK,"},
1316     {SVp_POK, "pPOK,"}
1317 };
1318
1319 const struct flag_to_name cv_flags_names[] = {
1320     {CVf_ANON, "ANON,"},
1321     {CVf_UNIQUE, "UNIQUE,"},
1322     {CVf_CLONE, "CLONE,"},
1323     {CVf_CLONED, "CLONED,"},
1324     {CVf_CONST, "CONST,"},
1325     {CVf_NODEBUG, "NODEBUG,"},
1326     {CVf_LVALUE, "LVALUE,"},
1327     {CVf_METHOD, "METHOD,"},
1328     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1329     {CVf_CVGV_RC, "CVGV_RC,"},
1330     {CVf_DYNFILE, "DYNFILE,"},
1331     {CVf_AUTOLOAD, "AUTOLOAD,"},
1332     {CVf_HASEVAL, "HASEVAL,"},
1333     {CVf_SLABBED, "SLABBED,"},
1334     {CVf_NAMED, "NAMED,"},
1335     {CVf_LEXICAL, "LEXICAL,"},
1336     {CVf_ISXSUB, "ISXSUB,"}
1337 };
1338
1339 const struct flag_to_name hv_flags_names[] = {
1340     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1341     {SVphv_LAZYDEL, "LAZYDEL,"},
1342     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1343     {SVf_AMAGIC, "OVERLOAD,"},
1344     {SVphv_CLONEABLE, "CLONEABLE,"}
1345 };
1346
1347 const struct flag_to_name gp_flags_names[] = {
1348     {GVf_INTRO, "INTRO,"},
1349     {GVf_MULTI, "MULTI,"},
1350     {GVf_ASSUMECV, "ASSUMECV,"},
1351 };
1352
1353 const struct flag_to_name gp_flags_imported_names[] = {
1354     {GVf_IMPORTED_SV, " SV"},
1355     {GVf_IMPORTED_AV, " AV"},
1356     {GVf_IMPORTED_HV, " HV"},
1357     {GVf_IMPORTED_CV, " CV"},
1358 };
1359
1360 /* NOTE: this structure is mostly duplicative of one generated by
1361  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1362  * the two. - Yves */
1363 const struct flag_to_name regexp_extflags_names[] = {
1364     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1365     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1366     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1367     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1368     {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1369     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1370     {RXf_IS_ANCHORED,     "IS_ANCHORED,"},
1371     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1372     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1373     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1374     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1375     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1376     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1377     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1378     {RXf_SPLIT,           "SPLIT,"},
1379     {RXf_COPY_DONE,       "COPY_DONE,"},
1380     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1381     {RXf_TAINTED,         "TAINTED,"},
1382     {RXf_START_ONLY,      "START_ONLY,"},
1383     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1384     {RXf_WHITE,           "WHITE,"},
1385     {RXf_NULL,            "NULL,"},
1386 };
1387
1388 /* NOTE: this structure is mostly duplicative of one generated by
1389  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1390  * the two. - Yves */
1391 const struct flag_to_name regexp_core_intflags_names[] = {
1392     {PREGf_SKIP,            "SKIP,"},
1393     {PREGf_IMPLICIT,        "IMPLICIT,"},
1394     {PREGf_NAUGHTY,         "NAUGHTY,"},
1395     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1396     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1397     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1398     {PREGf_NOSCAN,          "NOSCAN,"},
1399     {PREGf_CANY_SEEN,       "CANY_SEEN,"},
1400     {PREGf_GPOS_SEEN,       "GPOS_SEEN,"},
1401     {PREGf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1402     {PREGf_ANCH_MBOL,       "ANCH_MBOL,"},
1403     {PREGf_ANCH_SBOL,       "ANCH_SBOL,"},
1404     {PREGf_ANCH_GPOS,       "ANCH_GPOS,"},
1405 };
1406
1407 void
1408 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1409 {
1410     SV *d;
1411     const char *s;
1412     U32 flags;
1413     U32 type;
1414
1415     PERL_ARGS_ASSERT_DO_SV_DUMP;
1416
1417     if (!sv) {
1418         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1419         return;
1420     }
1421
1422     flags = SvFLAGS(sv);
1423     type = SvTYPE(sv);
1424
1425     /* process general SV flags */
1426
1427     d = Perl_newSVpvf(aTHX_
1428                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1429                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1430                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1431                    (int)(PL_dumpindent*level), "");
1432
1433     if (!((flags & SVpad_NAME) == SVpad_NAME
1434           && (type == SVt_PVMG || type == SVt_PVNV))) {
1435         if ((flags & SVs_PADSTALE))
1436             sv_catpv(d, "PADSTALE,");
1437     }
1438     if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1439         if ((flags & SVs_PADTMP))
1440             sv_catpv(d, "PADTMP,");
1441     }
1442     append_flags(d, flags, first_sv_flags_names);
1443     if (flags & SVf_ROK)  {
1444                                 sv_catpv(d, "ROK,");
1445         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1446     }
1447     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1448     append_flags(d, flags, second_sv_flags_names);
1449     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1450                            && type != SVt_PVAV) {
1451         if (SvPCS_IMPORTED(sv))
1452                                 sv_catpv(d, "PCS_IMPORTED,");
1453         else
1454                                 sv_catpv(d, "SCREAM,");
1455     }
1456
1457     /* process type-specific SV flags */
1458
1459     switch (type) {
1460     case SVt_PVCV:
1461     case SVt_PVFM:
1462         append_flags(d, CvFLAGS(sv), cv_flags_names);
1463         break;
1464     case SVt_PVHV:
1465         append_flags(d, flags, hv_flags_names);
1466         break;
1467     case SVt_PVGV:
1468     case SVt_PVLV:
1469         if (isGV_with_GP(sv)) {
1470             append_flags(d, GvFLAGS(sv), gp_flags_names);
1471         }
1472         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1473             sv_catpv(d, "IMPORT");
1474             if (GvIMPORTED(sv) == GVf_IMPORTED)
1475                 sv_catpv(d, "ALL,");
1476             else {
1477                 sv_catpv(d, "(");
1478                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1479                 sv_catpv(d, " ),");
1480             }
1481         }
1482         /* FALLTHROUGH */
1483     default:
1484     evaled_or_uv:
1485         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1486         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1487         break;
1488     case SVt_PVMG:
1489         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1490         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1491         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1492         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1493         /* FALLTHROUGH */
1494     case SVt_PVNV:
1495         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1496         goto evaled_or_uv;
1497     case SVt_PVAV:
1498         if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
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 if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1646             Perl_dump_indent(aTHX_ level, file, "  MAXNAMED = %"UVuf"\n",
1647                                    (UV)PadnamelistMAXNAMED(sv));
1648         } else {
1649             if (SvMAGIC(sv))
1650                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1651         }
1652         if (SvSTASH(sv))
1653             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1654
1655         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1656             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1657         }
1658     }
1659
1660     /* Dump type-specific SV fields */
1661
1662     switch (type) {
1663     case SVt_PVAV:
1664         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1665         if (AvARRAY(sv) != AvALLOC(sv)) {
1666             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1667             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1668         }
1669         else
1670             PerlIO_putc(file, '\n');
1671         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1672         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1673         /* arylen is stored in magic, and padnamelists use SvMAGIC for
1674            something else. */
1675         if (!AvPAD_NAMELIST(sv))
1676             Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n",
1677                                    SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1678         sv_setpvs(d, "");
1679         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1680         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1681         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1682                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1683         if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1684             SSize_t count;
1685             for (count = 0; count <=  av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1686                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1687
1688                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1689                 if (elt)
1690                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1691             }
1692         }
1693         break;
1694     case SVt_PVHV: {
1695         U32 usedkeys;
1696         if (SvOOK(sv)) {
1697             struct xpvhv_aux *const aux = HvAUX(sv);
1698             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %"UVuf"\n",
1699                              (UV)aux->xhv_aux_flags);
1700         }
1701         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1702         usedkeys = HvUSEDKEYS(sv);
1703         if (HvARRAY(sv) && usedkeys) {
1704             /* Show distribution of HEs in the ARRAY */
1705             int freq[200];
1706 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1707             int i;
1708             int max = 0;
1709             U32 pow2 = 2, keys = usedkeys;
1710             NV theoret, sum = 0;
1711
1712             PerlIO_printf(file, "  (");
1713             Zero(freq, FREQ_MAX + 1, int);
1714             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1715                 HE* h;
1716                 int count = 0;
1717                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1718                     count++;
1719                 if (count > FREQ_MAX)
1720                     count = FREQ_MAX;
1721                 freq[count]++;
1722                 if (max < count)
1723                     max = count;
1724             }
1725             for (i = 0; i <= max; i++) {
1726                 if (freq[i]) {
1727                     PerlIO_printf(file, "%d%s:%d", i,
1728                                   (i == FREQ_MAX) ? "+" : "",
1729                                   freq[i]);
1730                     if (i != max)
1731                         PerlIO_printf(file, ", ");
1732                 }
1733             }
1734             PerlIO_putc(file, ')');
1735             /* The "quality" of a hash is defined as the total number of
1736                comparisons needed to access every element once, relative
1737                to the expected number needed for a random hash.
1738
1739                The total number of comparisons is equal to the sum of
1740                the squares of the number of entries in each bucket.
1741                For a random hash of n keys into k buckets, the expected
1742                value is
1743                                 n + n(n-1)/2k
1744             */
1745
1746             for (i = max; i > 0; i--) { /* Precision: count down. */
1747                 sum += freq[i] * i * i;
1748             }
1749             while ((keys = keys >> 1))
1750                 pow2 = pow2 << 1;
1751             theoret = usedkeys;
1752             theoret += theoret * (theoret-1)/pow2;
1753             PerlIO_putc(file, '\n');
1754             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1755         }
1756         PerlIO_putc(file, '\n');
1757         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)usedkeys);
1758         {
1759             STRLEN count = 0;
1760             HE **ents = HvARRAY(sv);
1761
1762             if (ents) {
1763                 HE *const *const last = ents + HvMAX(sv);
1764                 count = last + 1 - ents;
1765
1766                 do {
1767                     if (!*ents)
1768                         --count;
1769                 } while (++ents <= last);
1770             }
1771
1772             if (SvOOK(sv)) {
1773                 struct xpvhv_aux *const aux = HvAUX(sv);
1774                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf
1775                                  " (cached = %"UVuf")\n",
1776                                  (UV)count, (UV)aux->xhv_fill_lazy);
1777             } else {
1778                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
1779                                  (UV)count);
1780             }
1781         }
1782         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1783         if (SvOOK(sv)) {
1784             Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1785             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1786 #ifdef PERL_HASH_RANDOMIZE_KEYS
1787             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1788             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1789                 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1790             }
1791 #endif
1792             PerlIO_putc(file, '\n');
1793         }
1794         {
1795             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1796             if (mg && mg->mg_obj) {
1797                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1798             }
1799         }
1800         {
1801             const char * const hvname = HvNAME_get(sv);
1802             if (hvname) {
1803           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1804      Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1805                                        generic_pv_escape( tmpsv, hvname,
1806                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
1807         }
1808         }
1809         if (SvOOK(sv)) {
1810             AV * const backrefs
1811                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1812             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1813             if (HvAUX(sv)->xhv_name_count)
1814                 Perl_dump_indent(aTHX_
1815                  level, file, "  NAMECOUNT = %"IVdf"\n",
1816                  (IV)HvAUX(sv)->xhv_name_count
1817                 );
1818             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1819                 const I32 count = HvAUX(sv)->xhv_name_count;
1820                 if (count) {
1821                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1822                     /* The starting point is the first element if count is
1823                        positive and the second element if count is negative. */
1824                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1825                         + (count < 0 ? 1 : 0);
1826                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1827                         + (count < 0 ? -count : count);
1828                     while (hekp < endp) {
1829                         if (HEK_LEN(*hekp)) {
1830              SV *tmp = newSVpvs_flags("", SVs_TEMP);
1831                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1832                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1833                         } else {
1834                             /* This should never happen. */
1835                             sv_catpvs(names, ", (null)");
1836                         }
1837                         ++hekp;
1838                     }
1839                     Perl_dump_indent(aTHX_
1840                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1841                     );
1842                 }
1843                 else {
1844                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1845                     const char *const hvename = HvENAME_get(sv);
1846                     Perl_dump_indent(aTHX_
1847                      level, file, "  ENAME = \"%s\"\n",
1848                      generic_pv_escape(tmp, hvename,
1849                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1850                 }
1851             }
1852             if (backrefs) {
1853                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1854                                  PTR2UV(backrefs));
1855                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1856                            dumpops, pvlim);
1857             }
1858             if (meta) {
1859                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1860                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1861                                  generic_pv_escape( tmpsv, meta->mro_which->name,
1862                                 meta->mro_which->length,
1863                                 (meta->mro_which->kflags & HVhek_UTF8)),
1864                                  PTR2UV(meta->mro_which));
1865                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1866                                  (UV)meta->cache_gen);
1867                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1868                                  (UV)meta->pkg_gen);
1869                 if (meta->mro_linear_all) {
1870                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1871                                  PTR2UV(meta->mro_linear_all));
1872                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1873                            dumpops, pvlim);
1874                 }
1875                 if (meta->mro_linear_current) {
1876                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1877                                  PTR2UV(meta->mro_linear_current));
1878                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1879                            dumpops, pvlim);
1880                 }
1881                 if (meta->mro_nextmethod) {
1882                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1883                                  PTR2UV(meta->mro_nextmethod));
1884                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1885                            dumpops, pvlim);
1886                 }
1887                 if (meta->isa) {
1888                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1889                                  PTR2UV(meta->isa));
1890                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1891                            dumpops, pvlim);
1892                 }
1893             }
1894         }
1895         if (nest < maxnest) {
1896             HV * const hv = MUTABLE_HV(sv);
1897             STRLEN i;
1898             HE *he;
1899
1900             if (HvARRAY(hv)) {
1901                 int count = maxnest - nest;
1902                 for (i=0; i <= HvMAX(hv); i++) {
1903                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1904                         U32 hash;
1905                         SV * keysv;
1906                         const char * keypv;
1907                         SV * elt;
1908                         STRLEN len;
1909
1910                         if (count-- <= 0) goto DONEHV;
1911
1912                         hash = HeHASH(he);
1913                         keysv = hv_iterkeysv(he);
1914                         keypv = SvPV_const(keysv, len);
1915                         elt = HeVAL(he);
1916
1917                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1918                         if (SvUTF8(keysv))
1919                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1920                         if (HvEITER_get(hv) == he)
1921                             PerlIO_printf(file, "[CURRENT] ");
1922                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1923                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1924                     }
1925                 }
1926               DONEHV:;
1927             }
1928         }
1929         break;
1930     } /* case SVt_PVHV */
1931
1932     case SVt_PVCV:
1933         if (CvAUTOLOAD(sv)) {
1934             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1935        STRLEN len;
1936             const char *const name =  SvPV_const(sv, len);
1937             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
1938                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1939         }
1940         if (SvPOK(sv)) {
1941        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1942        const char *const proto = CvPROTO(sv);
1943             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
1944                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1945                                 SvUTF8(sv)));
1946         }
1947         /* FALLTHROUGH */
1948     case SVt_PVFM:
1949         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1950         if (!CvISXSUB(sv)) {
1951             if (CvSTART(sv)) {
1952                 Perl_dump_indent(aTHX_ level, file,
1953                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1954                                  PTR2UV(CvSTART(sv)),
1955                                  (IV)sequence_num(CvSTART(sv)));
1956             }
1957             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1958                              PTR2UV(CvROOT(sv)));
1959             if (CvROOT(sv) && dumpops) {
1960                 do_op_dump(level+1, file, CvROOT(sv));
1961             }
1962         } else {
1963             SV * const constant = cv_const_sv((const CV *)sv);
1964
1965             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1966
1967             if (constant) {
1968                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1969                                  " (CONST SV)\n",
1970                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1971                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1972                            pvlim);
1973             } else {
1974                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1975                                  (IV)CvXSUBANY(sv).any_i32);
1976             }
1977         }
1978         if (CvNAMED(sv))
1979             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1980                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
1981         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1982         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1983         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1984         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1985         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1986         if (!CvISXSUB(sv)) {
1987             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1988             if (nest < maxnest) {
1989                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1990             }
1991         }
1992         else
1993             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
1994         {
1995             const CV * const outside = CvOUTSIDE(sv);
1996             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1997                         PTR2UV(outside),
1998                         (!outside ? "null"
1999                          : CvANON(outside) ? "ANON"
2000                          : (outside == PL_main_cv) ? "MAIN"
2001                          : CvUNIQUE(outside) ? "UNIQUE"
2002                          : CvGV(outside) ?
2003                              generic_pv_escape(
2004                                  newSVpvs_flags("", SVs_TEMP),
2005                                  GvNAME(CvGV(outside)),
2006                                  GvNAMELEN(CvGV(outside)),
2007                                  GvNAMEUTF8(CvGV(outside)))
2008                          : "UNDEFINED"));
2009         }
2010         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2011             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2012         break;
2013
2014     case SVt_PVGV:
2015     case SVt_PVLV:
2016         if (type == SVt_PVLV) {
2017             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2018             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2019             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2020             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2021             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2022             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2023                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2024                     dumpops, pvlim);
2025         }
2026         if (isREGEXP(sv)) goto dumpregexp;
2027         if (!isGV_with_GP(sv))
2028             break;
2029        {
2030           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2031           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2032                     generic_pv_escape(tmpsv, GvNAME(sv),
2033                                       GvNAMELEN(sv),
2034                                       GvNAMEUTF8(sv)));
2035        }
2036         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2037         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2038         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2039         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2040         if (!GvGP(sv))
2041             break;
2042         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2043         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2044         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2045         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2046         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2047         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2048         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2049         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2050         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%"UVxf
2051                                             " (%s)\n",
2052                                (UV)GvGPFLAGS(sv),
2053                                GvALIASED_SV(sv) ? "ALIASED_SV" : "");
2054         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2055         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2056         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2057         break;
2058     case SVt_PVIO:
2059         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2060         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2061         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2062         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2063         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2064         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2065         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2066         if (IoTOP_NAME(sv))
2067             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2068         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2069             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2070         else {
2071             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2072                              PTR2UV(IoTOP_GV(sv)));
2073             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2074                         maxnest, dumpops, pvlim);
2075         }
2076         /* Source filters hide things that are not GVs in these three, so let's
2077            be careful out there.  */
2078         if (IoFMT_NAME(sv))
2079             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2080         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2081             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2082         else {
2083             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2084                              PTR2UV(IoFMT_GV(sv)));
2085             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2086                         maxnest, dumpops, pvlim);
2087         }
2088         if (IoBOTTOM_NAME(sv))
2089             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2090         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2091             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2092         else {
2093             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2094                              PTR2UV(IoBOTTOM_GV(sv)));
2095             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2096                         maxnest, dumpops, pvlim);
2097         }
2098         if (isPRINT(IoTYPE(sv)))
2099             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2100         else
2101             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2102         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2103         break;
2104     case SVt_REGEXP:
2105       dumpregexp:
2106         {
2107             struct regexp * const r = ReANY((REGEXP*)sv);
2108
2109 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2110             sv_setpv(d,"");                                 \
2111             append_flags(d, flags, names);     \
2112             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2113                 SvCUR_set(d, SvCUR(d) - 1);                 \
2114                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2115             }                                               \
2116 } STMT_END
2117             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2118             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
2119                                 (UV)(r->compflags), SvPVX_const(d));
2120
2121             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2122             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2123                                 (UV)(r->extflags), SvPVX_const(d));
2124
2125             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf" (%s)\n",
2126                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2127             if (r->engine == &PL_core_reg_engine) {
2128                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2129                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf" (%s)\n",
2130                                 (UV)(r->intflags), SvPVX_const(d));
2131             } else {
2132                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2133                                 (UV)(r->intflags));
2134             }
2135 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2136             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2137                                 (UV)(r->nparens));
2138             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2139                                 (UV)(r->lastparen));
2140             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2141                                 (UV)(r->lastcloseparen));
2142             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2143                                 (IV)(r->minlen));
2144             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2145                                 (IV)(r->minlenret));
2146             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2147                                 (UV)(r->gofs));
2148             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2149                                 (UV)(r->pre_prefix));
2150             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2151                                 (IV)(r->sublen));
2152             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
2153                                 (IV)(r->suboffset));
2154             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
2155                                 (IV)(r->subcoffset));
2156             if (r->subbeg)
2157                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2158                             PTR2UV(r->subbeg),
2159                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2160             else
2161                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2162             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2163                                 PTR2UV(r->mother_re));
2164             if (nest < maxnest && r->mother_re)
2165                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2166                            maxnest, dumpops, pvlim);
2167             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2168                                 PTR2UV(r->paren_names));
2169             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2170                                 PTR2UV(r->substrs));
2171             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2172                                 PTR2UV(r->pprivate));
2173             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2174                                 PTR2UV(r->offs));
2175             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2176                                 PTR2UV(r->qr_anoncv));
2177 #ifdef PERL_ANY_COW
2178             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2179                                 PTR2UV(r->saved_copy));
2180 #endif
2181         }
2182         break;
2183     }
2184     SvREFCNT_dec_NN(d);
2185 }
2186
2187 /*
2188 =for apidoc sv_dump
2189
2190 Dumps the contents of an SV to the C<STDERR> filehandle.
2191
2192 For an example of its output, see L<Devel::Peek>.
2193
2194 =cut
2195 */
2196
2197 void
2198 Perl_sv_dump(pTHX_ SV *sv)
2199 {
2200     PERL_ARGS_ASSERT_SV_DUMP;
2201
2202     if (SvROK(sv))
2203         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2204     else
2205         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2206 }
2207
2208 int
2209 Perl_runops_debug(pTHX)
2210 {
2211     if (!PL_op) {
2212         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2213         return 0;
2214     }
2215
2216     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2217     do {
2218 #ifdef PERL_TRACE_OPS
2219         ++PL_op_exec_cnt[PL_op->op_type];
2220 #endif
2221         if (PL_debug) {
2222             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2223                 PerlIO_printf(Perl_debug_log,
2224                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2225                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2226                               PTR2UV(*PL_watchaddr));
2227             if (DEBUG_s_TEST_) {
2228                 if (DEBUG_v_TEST_) {
2229                     PerlIO_printf(Perl_debug_log, "\n");
2230                     deb_stack_all();
2231                 }
2232                 else
2233                     debstack();
2234             }
2235
2236
2237             if (DEBUG_t_TEST_) debop(PL_op);
2238             if (DEBUG_P_TEST_) debprof(PL_op);
2239         }
2240
2241         OP_ENTRY_PROBE(OP_NAME(PL_op));
2242     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2243     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2244     PERL_ASYNC_CHECK();
2245
2246     TAINT_NOT;
2247     return 0;
2248 }
2249
2250 I32
2251 Perl_debop(pTHX_ const OP *o)
2252 {
2253     int count;
2254
2255     PERL_ARGS_ASSERT_DEBOP;
2256
2257     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2258         return 0;
2259
2260     Perl_deb(aTHX_ "%s", OP_NAME(o));
2261     switch (o->op_type) {
2262     case OP_CONST:
2263     case OP_HINTSEVAL:
2264         /* With ITHREADS, consts are stored in the pad, and the right pad
2265          * may not be active here, so check.
2266          * Looks like only during compiling the pads are illegal.
2267          */
2268 #ifdef USE_ITHREADS
2269         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2270 #endif
2271             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2272         break;
2273     case OP_GVSV:
2274     case OP_GV:
2275         if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2276             SV * const sv = newSV(0);
2277             gv_fullname3(sv, cGVOPo_gv, NULL);
2278             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2279             SvREFCNT_dec_NN(sv);
2280         }
2281         else if (cGVOPo_gv) {
2282             SV * const sv = newSV(0);
2283             assert(SvROK(cGVOPo_gv));
2284             assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2285             PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2286                     SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2287             SvREFCNT_dec_NN(sv);
2288         }
2289         else
2290             PerlIO_printf(Perl_debug_log, "(NULL)");
2291         break;
2292
2293     case OP_PADSV:
2294     case OP_PADAV:
2295     case OP_PADHV:
2296         count = 1;
2297         goto dump_padop;
2298     case OP_PADRANGE:
2299         count = o->op_private & OPpPADRANGE_COUNTMASK;
2300     dump_padop:
2301         /* print the lexical's name */
2302         {
2303             CV * const cv = deb_curcv(cxstack_ix);
2304             SV *sv;
2305             PAD * comppad = NULL;
2306             int i;
2307
2308             if (cv) {
2309                 PADLIST * const padlist = CvPADLIST(cv);
2310                 comppad = *PadlistARRAY(padlist);
2311             }
2312             PerlIO_printf(Perl_debug_log, "(");
2313             for (i = 0; i < count; i++) {
2314                 if (comppad &&
2315                         (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2316                     PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2317                 else
2318                     PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2319                             (UV)o->op_targ+i);
2320                 if (i < count-1)
2321                     PerlIO_printf(Perl_debug_log, ",");
2322             }
2323             PerlIO_printf(Perl_debug_log, ")");
2324         }
2325         break;
2326
2327     default:
2328         break;
2329     }
2330     PerlIO_printf(Perl_debug_log, "\n");
2331     return 0;
2332 }
2333
2334 STATIC CV*
2335 S_deb_curcv(pTHX_ const I32 ix)
2336 {
2337     const PERL_CONTEXT * const cx = &cxstack[ix];
2338     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2339         return cx->blk_sub.cv;
2340     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2341         return cx->blk_eval.cv;
2342     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2343         return PL_main_cv;
2344     else if (ix <= 0)
2345         return NULL;
2346     else
2347         return deb_curcv(ix - 1);
2348 }
2349
2350 void
2351 Perl_watch(pTHX_ char **addr)
2352 {
2353     PERL_ARGS_ASSERT_WATCH;
2354
2355     PL_watchaddr = addr;
2356     PL_watchok = *addr;
2357     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2358         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2359 }
2360
2361 STATIC void
2362 S_debprof(pTHX_ const OP *o)
2363 {
2364     PERL_ARGS_ASSERT_DEBPROF;
2365
2366     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2367         return;
2368     if (!PL_profiledata)
2369         Newxz(PL_profiledata, MAXO, U32);
2370     ++PL_profiledata[o->op_type];
2371 }
2372
2373 void
2374 Perl_debprofdump(pTHX)
2375 {
2376     unsigned i;
2377     if (!PL_profiledata)
2378         return;
2379     for (i = 0; i < MAXO; i++) {
2380         if (PL_profiledata[i])
2381             PerlIO_printf(Perl_debug_log,
2382                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2383                                        PL_op_name[i]);
2384     }
2385 }
2386
2387
2388 /*
2389  * Local variables:
2390  * c-indentation-style: bsd
2391  * c-basic-offset: 4
2392  * indent-tabs-mode: nil
2393  * End:
2394  *
2395  * ex: set ts=8 sts=4 sw=4 et:
2396  */