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