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 = OP_SIBLING(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_IS_ANCHORED,     "IS_ANCHORED,"},
1386     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1387     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1388     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1389     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1390     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1391     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1392     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1393     {RXf_SPLIT,           "SPLIT,"},
1394     {RXf_COPY_DONE,       "COPY_DONE,"},
1395     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1396     {RXf_TAINTED,         "TAINTED,"},
1397     {RXf_START_ONLY,      "START_ONLY,"},
1398     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1399     {RXf_WHITE,           "WHITE,"},
1400     {RXf_NULL,            "NULL,"},
1401 };
1402
1403 /* NOTE: this structure is mostly duplicative of one generated by
1404  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1405  * the two. - Yves */
1406 const struct flag_to_name regexp_core_intflags_names[] = {
1407     {PREGf_SKIP,            "SKIP,"},
1408     {PREGf_IMPLICIT,        "IMPLICIT,"},
1409     {PREGf_NAUGHTY,         "NAUGHTY,"},
1410     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1411     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1412     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1413     {PREGf_NOSCAN,          "NOSCAN,"},
1414     {PREGf_CANY_SEEN,       "CANY_SEEN,"},
1415     {PREGf_GPOS_SEEN,       "GPOS_SEEN,"},
1416     {PREGf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1417     {PREGf_ANCH_MBOL,       "ANCH_MBOL,"},
1418     {PREGf_ANCH_SBOL,       "ANCH_SBOL,"},
1419     {PREGf_ANCH_GPOS,       "ANCH_GPOS,"},
1420 };
1421
1422 void
1423 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1424 {
1425     SV *d;
1426     const char *s;
1427     U32 flags;
1428     U32 type;
1429
1430     PERL_ARGS_ASSERT_DO_SV_DUMP;
1431
1432     if (!sv) {
1433         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1434         return;
1435     }
1436
1437     flags = SvFLAGS(sv);
1438     type = SvTYPE(sv);
1439
1440     /* process general SV flags */
1441
1442     d = Perl_newSVpvf(aTHX_
1443                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1444                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1445                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1446                    (int)(PL_dumpindent*level), "");
1447
1448     if ((flags & SVs_PADSTALE))
1449             sv_catpv(d, "PADSTALE,");
1450     if ((flags & SVs_PADTMP))
1451             sv_catpv(d, "PADTMP,");
1452     append_flags(d, flags, first_sv_flags_names);
1453     if (flags & SVf_ROK)  {
1454                                 sv_catpv(d, "ROK,");
1455         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1456     }
1457     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1458     append_flags(d, flags, second_sv_flags_names);
1459     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1460                            && type != SVt_PVAV) {
1461         if (SvPCS_IMPORTED(sv))
1462                                 sv_catpv(d, "PCS_IMPORTED,");
1463         else
1464                                 sv_catpv(d, "SCREAM,");
1465     }
1466
1467     /* process type-specific SV flags */
1468
1469     switch (type) {
1470     case SVt_PVCV:
1471     case SVt_PVFM:
1472         append_flags(d, CvFLAGS(sv), cv_flags_names);
1473         break;
1474     case SVt_PVHV:
1475         append_flags(d, flags, hv_flags_names);
1476         break;
1477     case SVt_PVGV:
1478     case SVt_PVLV:
1479         if (isGV_with_GP(sv)) {
1480             append_flags(d, GvFLAGS(sv), gp_flags_names);
1481         }
1482         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1483             sv_catpv(d, "IMPORT");
1484             if (GvIMPORTED(sv) == GVf_IMPORTED)
1485                 sv_catpv(d, "ALL,");
1486             else {
1487                 sv_catpv(d, "(");
1488                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1489                 sv_catpv(d, " ),");
1490             }
1491         }
1492         /* FALLTHROUGH */
1493     default:
1494     evaled_or_uv:
1495         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1496         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1497         break;
1498     case SVt_PVMG:
1499         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1500         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1501         /* FALLTHROUGH */
1502         goto evaled_or_uv;
1503     case SVt_PVAV:
1504         break;
1505     }
1506     /* SVphv_SHAREKEYS is also 0x20000000 */
1507     if ((type != SVt_PVHV) && SvUTF8(sv))
1508         sv_catpv(d, "UTF8");
1509
1510     if (*(SvEND(d) - 1) == ',') {
1511         SvCUR_set(d, SvCUR(d) - 1);
1512         SvPVX(d)[SvCUR(d)] = '\0';
1513     }
1514     sv_catpv(d, ")");
1515     s = SvPVX_const(d);
1516
1517     /* dump initial SV details */
1518
1519 #ifdef DEBUG_LEAKING_SCALARS
1520     Perl_dump_indent(aTHX_ level, file,
1521         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1522         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1523         sv->sv_debug_line,
1524         sv->sv_debug_inpad ? "for" : "by",
1525         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1526         PTR2UV(sv->sv_debug_parent),
1527         sv->sv_debug_serial
1528     );
1529 #endif
1530     Perl_dump_indent(aTHX_ level, file, "SV = ");
1531
1532     /* Dump SV type */
1533
1534     if (type < SVt_LAST) {
1535         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1536
1537         if (type ==  SVt_NULL) {
1538             SvREFCNT_dec_NN(d);
1539             return;
1540         }
1541     } else {
1542         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1543         SvREFCNT_dec_NN(d);
1544         return;
1545     }
1546
1547     /* Dump general SV fields */
1548
1549     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1550          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1551          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1552         || (type == SVt_IV && !SvROK(sv))) {
1553         if (SvIsUV(sv)
1554 #ifdef PERL_OLD_COPY_ON_WRITE
1555                        || SvIsCOW(sv)
1556 #endif
1557                                      )
1558             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1559         else
1560             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1561 #ifdef PERL_OLD_COPY_ON_WRITE
1562         if (SvIsCOW_shared_hash(sv))
1563             PerlIO_printf(file, "  (HASH)");
1564         else if (SvIsCOW_normal(sv))
1565             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1566 #endif
1567         PerlIO_putc(file, '\n');
1568     }
1569
1570     if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1571                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1572                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1573                || type == SVt_NV) {
1574         STORE_NUMERIC_LOCAL_SET_STANDARD();
1575         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1576         RESTORE_NUMERIC_LOCAL();
1577     }
1578
1579     if (SvROK(sv)) {
1580         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1581         if (nest < maxnest)
1582             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1583     }
1584
1585     if (type < SVt_PV) {
1586         SvREFCNT_dec_NN(d);
1587         return;
1588     }
1589
1590     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1591      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1592         const bool re = isREGEXP(sv);
1593         const char * const ptr =
1594             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1595         if (ptr) {
1596             STRLEN delta;
1597             if (SvOOK(sv)) {
1598                 SvOOK_offset(sv, delta);
1599                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1600                                  (UV) delta);
1601             } else {
1602                 delta = 0;
1603             }
1604             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(ptr));
1605             if (SvOOK(sv)) {
1606                 PerlIO_printf(file, "( %s . ) ",
1607                               pv_display(d, ptr - delta, delta, 0,
1608                                          pvlim));
1609             }
1610             if (type == SVt_INVLIST) {
1611                 PerlIO_printf(file, "\n");
1612                 /* 4 blanks indents 2 beyond the PV, etc */
1613                 _invlist_dump(file, level, "    ", sv);
1614             }
1615             else {
1616                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1617                                                      re ? 0 : SvLEN(sv),
1618                                                      pvlim));
1619                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1620                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1621                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1622                                                         UNI_DISPLAY_QQ));
1623                 PerlIO_printf(file, "\n");
1624             }
1625             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1626             if (!re)
1627                 Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
1628                                        (IV)SvLEN(sv));
1629 #ifdef PERL_NEW_COPY_ON_WRITE
1630             if (SvIsCOW(sv) && SvLEN(sv))
1631                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1632                                        CowREFCNT(sv));
1633 #endif
1634         }
1635         else
1636             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1637     }
1638
1639     if (type >= SVt_PVMG) {
1640         if (SvMAGIC(sv))
1641                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1642         if (SvSTASH(sv))
1643             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1644
1645         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1646             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1647         }
1648     }
1649
1650     /* Dump type-specific SV fields */
1651
1652     switch (type) {
1653     case SVt_PVAV:
1654         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1655         if (AvARRAY(sv) != AvALLOC(sv)) {
1656             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1657             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1658         }
1659         else
1660             PerlIO_putc(file, '\n');
1661         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1662         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1663         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n",
1664                                    SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1665         sv_setpvs(d, "");
1666         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1667         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1668         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1669                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1670         if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
1671             SSize_t count;
1672             for (count = 0; count <=  av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
1673                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1674
1675                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1676                 if (elt)
1677                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1678             }
1679         }
1680         break;
1681     case SVt_PVHV: {
1682         U32 usedkeys;
1683         if (SvOOK(sv)) {
1684             struct xpvhv_aux *const aux = HvAUX(sv);
1685             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %"UVuf"\n",
1686                              (UV)aux->xhv_aux_flags);
1687         }
1688         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1689         usedkeys = HvUSEDKEYS(sv);
1690         if (HvARRAY(sv) && usedkeys) {
1691             /* Show distribution of HEs in the ARRAY */
1692             int freq[200];
1693 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1694             int i;
1695             int max = 0;
1696             U32 pow2 = 2, keys = usedkeys;
1697             NV theoret, sum = 0;
1698
1699             PerlIO_printf(file, "  (");
1700             Zero(freq, FREQ_MAX + 1, int);
1701             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1702                 HE* h;
1703                 int count = 0;
1704                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1705                     count++;
1706                 if (count > FREQ_MAX)
1707                     count = FREQ_MAX;
1708                 freq[count]++;
1709                 if (max < count)
1710                     max = count;
1711             }
1712             for (i = 0; i <= max; i++) {
1713                 if (freq[i]) {
1714                     PerlIO_printf(file, "%d%s:%d", i,
1715                                   (i == FREQ_MAX) ? "+" : "",
1716                                   freq[i]);
1717                     if (i != max)
1718                         PerlIO_printf(file, ", ");
1719                 }
1720             }
1721             PerlIO_putc(file, ')');
1722             /* The "quality" of a hash is defined as the total number of
1723                comparisons needed to access every element once, relative
1724                to the expected number needed for a random hash.
1725
1726                The total number of comparisons is equal to the sum of
1727                the squares of the number of entries in each bucket.
1728                For a random hash of n keys into k buckets, the expected
1729                value is
1730                                 n + n(n-1)/2k
1731             */
1732
1733             for (i = max; i > 0; i--) { /* Precision: count down. */
1734                 sum += freq[i] * i * i;
1735             }
1736             while ((keys = keys >> 1))
1737                 pow2 = pow2 << 1;
1738             theoret = usedkeys;
1739             theoret += theoret * (theoret-1)/pow2;
1740             PerlIO_putc(file, '\n');
1741             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1742         }
1743         PerlIO_putc(file, '\n');
1744         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)usedkeys);
1745         {
1746             STRLEN count = 0;
1747             HE **ents = HvARRAY(sv);
1748
1749             if (ents) {
1750                 HE *const *const last = ents + HvMAX(sv);
1751                 count = last + 1 - ents;
1752
1753                 do {
1754                     if (!*ents)
1755                         --count;
1756                 } while (++ents <= last);
1757             }
1758
1759             if (SvOOK(sv)) {
1760                 struct xpvhv_aux *const aux = HvAUX(sv);
1761                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf
1762                                  " (cached = %"UVuf")\n",
1763                                  (UV)count, (UV)aux->xhv_fill_lazy);
1764             } else {
1765                 Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
1766                                  (UV)count);
1767             }
1768         }
1769         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1770         if (SvOOK(sv)) {
1771             Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1772             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1773 #ifdef PERL_HASH_RANDOMIZE_KEYS
1774             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1775             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1776                 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1777             }
1778 #endif
1779             PerlIO_putc(file, '\n');
1780         }
1781         {
1782             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1783             if (mg && mg->mg_obj) {
1784                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1785             }
1786         }
1787         {
1788             const char * const hvname = HvNAME_get(sv);
1789             if (hvname) {
1790           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1791      Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1792                                        generic_pv_escape( tmpsv, hvname,
1793                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
1794         }
1795         }
1796         if (SvOOK(sv)) {
1797             AV * const backrefs
1798                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1799             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1800             if (HvAUX(sv)->xhv_name_count)
1801                 Perl_dump_indent(aTHX_
1802                  level, file, "  NAMECOUNT = %"IVdf"\n",
1803                  (IV)HvAUX(sv)->xhv_name_count
1804                 );
1805             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1806                 const I32 count = HvAUX(sv)->xhv_name_count;
1807                 if (count) {
1808                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1809                     /* The starting point is the first element if count is
1810                        positive and the second element if count is negative. */
1811                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1812                         + (count < 0 ? 1 : 0);
1813                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1814                         + (count < 0 ? -count : count);
1815                     while (hekp < endp) {
1816                         if (HEK_LEN(*hekp)) {
1817              SV *tmp = newSVpvs_flags("", SVs_TEMP);
1818                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1819                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1820                         } else {
1821                             /* This should never happen. */
1822                             sv_catpvs(names, ", (null)");
1823                         }
1824                         ++hekp;
1825                     }
1826                     Perl_dump_indent(aTHX_
1827                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1828                     );
1829                 }
1830                 else {
1831                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1832                     const char *const hvename = HvENAME_get(sv);
1833                     Perl_dump_indent(aTHX_
1834                      level, file, "  ENAME = \"%s\"\n",
1835                      generic_pv_escape(tmp, hvename,
1836                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1837                 }
1838             }
1839             if (backrefs) {
1840                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1841                                  PTR2UV(backrefs));
1842                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1843                            dumpops, pvlim);
1844             }
1845             if (meta) {
1846                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1847                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1848                                  generic_pv_escape( tmpsv, meta->mro_which->name,
1849                                 meta->mro_which->length,
1850                                 (meta->mro_which->kflags & HVhek_UTF8)),
1851                                  PTR2UV(meta->mro_which));
1852                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1853                                  (UV)meta->cache_gen);
1854                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1855                                  (UV)meta->pkg_gen);
1856                 if (meta->mro_linear_all) {
1857                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1858                                  PTR2UV(meta->mro_linear_all));
1859                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1860                            dumpops, pvlim);
1861                 }
1862                 if (meta->mro_linear_current) {
1863                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1864                                  PTR2UV(meta->mro_linear_current));
1865                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1866                            dumpops, pvlim);
1867                 }
1868                 if (meta->mro_nextmethod) {
1869                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1870                                  PTR2UV(meta->mro_nextmethod));
1871                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1872                            dumpops, pvlim);
1873                 }
1874                 if (meta->isa) {
1875                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1876                                  PTR2UV(meta->isa));
1877                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1878                            dumpops, pvlim);
1879                 }
1880             }
1881         }
1882         if (nest < maxnest) {
1883             HV * const hv = MUTABLE_HV(sv);
1884             STRLEN i;
1885             HE *he;
1886
1887             if (HvARRAY(hv)) {
1888                 int count = maxnest - nest;
1889                 for (i=0; i <= HvMAX(hv); i++) {
1890                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1891                         U32 hash;
1892                         SV * keysv;
1893                         const char * keypv;
1894                         SV * elt;
1895                         STRLEN len;
1896
1897                         if (count-- <= 0) goto DONEHV;
1898
1899                         hash = HeHASH(he);
1900                         keysv = hv_iterkeysv(he);
1901                         keypv = SvPV_const(keysv, len);
1902                         elt = HeVAL(he);
1903
1904                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1905                         if (SvUTF8(keysv))
1906                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1907                         if (HvEITER_get(hv) == he)
1908                             PerlIO_printf(file, "[CURRENT] ");
1909                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1910                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1911                     }
1912                 }
1913               DONEHV:;
1914             }
1915         }
1916         break;
1917     } /* case SVt_PVHV */
1918
1919     case SVt_PVCV:
1920         if (CvAUTOLOAD(sv)) {
1921             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1922        STRLEN len;
1923             const char *const name =  SvPV_const(sv, len);
1924             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
1925                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1926         }
1927         if (SvPOK(sv)) {
1928        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1929        const char *const proto = CvPROTO(sv);
1930             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
1931                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1932                                 SvUTF8(sv)));
1933         }
1934         /* FALLTHROUGH */
1935     case SVt_PVFM:
1936         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1937         if (!CvISXSUB(sv)) {
1938             if (CvSTART(sv)) {
1939                 Perl_dump_indent(aTHX_ level, file,
1940                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1941                                  PTR2UV(CvSTART(sv)),
1942                                  (IV)sequence_num(CvSTART(sv)));
1943             }
1944             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1945                              PTR2UV(CvROOT(sv)));
1946             if (CvROOT(sv) && dumpops) {
1947                 do_op_dump(level+1, file, CvROOT(sv));
1948             }
1949         } else {
1950             SV * const constant = cv_const_sv((const CV *)sv);
1951
1952             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1953
1954             if (constant) {
1955                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1956                                  " (CONST SV)\n",
1957                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1958                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1959                            pvlim);
1960             } else {
1961                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1962                                  (IV)CvXSUBANY(sv).any_i32);
1963             }
1964         }
1965         if (CvNAMED(sv))
1966             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1967                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
1968         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1969         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1970         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1971         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1972         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1973         if (!CvISXSUB(sv)) {
1974             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1975             if (nest < maxnest) {
1976                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1977             }
1978         }
1979         else
1980             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
1981         {
1982             const CV * const outside = CvOUTSIDE(sv);
1983             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1984                         PTR2UV(outside),
1985                         (!outside ? "null"
1986                          : CvANON(outside) ? "ANON"
1987                          : (outside == PL_main_cv) ? "MAIN"
1988                          : CvUNIQUE(outside) ? "UNIQUE"
1989                          : CvGV(outside) ?
1990                              generic_pv_escape(
1991                                  newSVpvs_flags("", SVs_TEMP),
1992                                  GvNAME(CvGV(outside)),
1993                                  GvNAMELEN(CvGV(outside)),
1994                                  GvNAMEUTF8(CvGV(outside)))
1995                          : "UNDEFINED"));
1996         }
1997         if (CvOUTSIDE(sv)
1998          && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
1999             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2000         break;
2001
2002     case SVt_PVGV:
2003     case SVt_PVLV:
2004         if (type == SVt_PVLV) {
2005             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2006             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2007             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2008             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2009             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2010             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2011                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2012                     dumpops, pvlim);
2013         }
2014         if (isREGEXP(sv)) goto dumpregexp;
2015         if (!isGV_with_GP(sv))
2016             break;
2017        {
2018           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2019           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2020                     generic_pv_escape(tmpsv, GvNAME(sv),
2021                                       GvNAMELEN(sv),
2022                                       GvNAMEUTF8(sv)));
2023        }
2024         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2025         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2026         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2027         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2028         if (!GvGP(sv))
2029             break;
2030         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2031         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2032         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2033         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2034         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2035         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2036         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2037         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2038         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%"UVxf
2039                                             " (%s)\n",
2040                                (UV)GvGPFLAGS(sv),
2041                                GvALIASED_SV(sv) ? "ALIASED_SV" : "");
2042         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2043         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2044         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2045         break;
2046     case SVt_PVIO:
2047         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2048         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2049         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2050         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2051         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2052         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2053         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2054         if (IoTOP_NAME(sv))
2055             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2056         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2057             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2058         else {
2059             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2060                              PTR2UV(IoTOP_GV(sv)));
2061             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2062                         maxnest, dumpops, pvlim);
2063         }
2064         /* Source filters hide things that are not GVs in these three, so let's
2065            be careful out there.  */
2066         if (IoFMT_NAME(sv))
2067             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2068         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2069             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2070         else {
2071             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2072                              PTR2UV(IoFMT_GV(sv)));
2073             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2074                         maxnest, dumpops, pvlim);
2075         }
2076         if (IoBOTTOM_NAME(sv))
2077             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2078         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2079             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2080         else {
2081             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2082                              PTR2UV(IoBOTTOM_GV(sv)));
2083             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2084                         maxnest, dumpops, pvlim);
2085         }
2086         if (isPRINT(IoTYPE(sv)))
2087             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2088         else
2089             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2090         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2091         break;
2092     case SVt_REGEXP:
2093       dumpregexp:
2094         {
2095             struct regexp * const r = ReANY((REGEXP*)sv);
2096
2097 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2098             sv_setpv(d,"");                                 \
2099             append_flags(d, flags, names);     \
2100             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2101                 SvCUR_set(d, SvCUR(d) - 1);                 \
2102                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2103             }                                               \
2104 } STMT_END
2105             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2106             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
2107                                 (UV)(r->compflags), SvPVX_const(d));
2108
2109             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2110             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2111                                 (UV)(r->extflags), SvPVX_const(d));
2112
2113             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf" (%s)\n",
2114                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2115             if (r->engine == &PL_core_reg_engine) {
2116                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2117                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf" (%s)\n",
2118                                 (UV)(r->intflags), SvPVX_const(d));
2119             } else {
2120                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2121                                 (UV)(r->intflags));
2122             }
2123 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2124             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2125                                 (UV)(r->nparens));
2126             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2127                                 (UV)(r->lastparen));
2128             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2129                                 (UV)(r->lastcloseparen));
2130             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2131                                 (IV)(r->minlen));
2132             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2133                                 (IV)(r->minlenret));
2134             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2135                                 (UV)(r->gofs));
2136             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2137                                 (UV)(r->pre_prefix));
2138             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2139                                 (IV)(r->sublen));
2140             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
2141                                 (IV)(r->suboffset));
2142             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
2143                                 (IV)(r->subcoffset));
2144             if (r->subbeg)
2145                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2146                             PTR2UV(r->subbeg),
2147                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2148             else
2149                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2150             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2151                                 PTR2UV(r->mother_re));
2152             if (nest < maxnest && r->mother_re)
2153                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2154                            maxnest, dumpops, pvlim);
2155             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2156                                 PTR2UV(r->paren_names));
2157             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2158                                 PTR2UV(r->substrs));
2159             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2160                                 PTR2UV(r->pprivate));
2161             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2162                                 PTR2UV(r->offs));
2163             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2164                                 PTR2UV(r->qr_anoncv));
2165 #ifdef PERL_ANY_COW
2166             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2167                                 PTR2UV(r->saved_copy));
2168 #endif
2169         }
2170         break;
2171     }
2172     SvREFCNT_dec_NN(d);
2173 }
2174
2175 /*
2176 =for apidoc sv_dump
2177
2178 Dumps the contents of an SV to the C<STDERR> filehandle.
2179
2180 For an example of its output, see L<Devel::Peek>.
2181
2182 =cut
2183 */
2184
2185 void
2186 Perl_sv_dump(pTHX_ SV *sv)
2187 {
2188     PERL_ARGS_ASSERT_SV_DUMP;
2189
2190     if (SvROK(sv))
2191         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2192     else
2193         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2194 }
2195
2196 int
2197 Perl_runops_debug(pTHX)
2198 {
2199     if (!PL_op) {
2200         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2201         return 0;
2202     }
2203
2204     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2205     do {
2206 #ifdef PERL_TRACE_OPS
2207         ++PL_op_exec_cnt[PL_op->op_type];
2208 #endif
2209         if (PL_debug) {
2210             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2211                 PerlIO_printf(Perl_debug_log,
2212                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2213                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2214                               PTR2UV(*PL_watchaddr));
2215             if (DEBUG_s_TEST_) {
2216                 if (DEBUG_v_TEST_) {
2217                     PerlIO_printf(Perl_debug_log, "\n");
2218                     deb_stack_all();
2219                 }
2220                 else
2221                     debstack();
2222             }
2223
2224
2225             if (DEBUG_t_TEST_) debop(PL_op);
2226             if (DEBUG_P_TEST_) debprof(PL_op);
2227         }
2228
2229         OP_ENTRY_PROBE(OP_NAME(PL_op));
2230     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2231     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2232     PERL_ASYNC_CHECK();
2233
2234     TAINT_NOT;
2235     return 0;
2236 }
2237
2238
2239 /* print the names of the n lexical vars starting at pad offset off */
2240
2241 void
2242 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2243 {
2244     PADNAME *sv;
2245     CV * const cv = deb_curcv(cxstack_ix);
2246     PADNAMELIST *comppad = NULL;
2247     int i;
2248
2249     if (cv) {
2250         PADLIST * const padlist = CvPADLIST(cv);
2251         comppad = PadlistNAMES(padlist);
2252     }
2253     if (paren)
2254         PerlIO_printf(Perl_debug_log, "(");
2255     for (i = 0; i < n; i++) {
2256         if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2257             PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2258         else
2259             PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2260                     (UV)(off+i));
2261         if (i < n - 1)
2262             PerlIO_printf(Perl_debug_log, ",");
2263     }
2264     if (paren)
2265         PerlIO_printf(Perl_debug_log, ")");
2266 }
2267
2268
2269 /* append to the out SV, the name of the lexical at offset off in the CV
2270  * cv */
2271
2272 void
2273 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2274         bool paren, bool is_scalar)
2275 {
2276     PADNAME *sv;
2277     PADNAMELIST *namepad = NULL;
2278     int i;
2279
2280     if (cv) {
2281         PADLIST * const padlist = CvPADLIST(cv);
2282         namepad = PadlistNAMES(padlist);
2283     }
2284
2285     if (paren)
2286         sv_catpvs_nomg(out, "(");
2287     for (i = 0; i < n; i++) {
2288         if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2289         {
2290             STRLEN cur = SvCUR(out);
2291             Perl_sv_catpvf(aTHX_ out, "[%"PNf, PNfARG(sv));
2292             if (is_scalar)
2293                 SvPVX(out)[cur] = '$';
2294         }
2295         else
2296             Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2297         if (i < n - 1)
2298             sv_catpvs_nomg(out, ",");
2299     }
2300     if (paren)
2301         sv_catpvs_nomg(out, "(");
2302 }
2303
2304
2305 void
2306 S_print_gv_name(pTHX_ GV *gv, SV *out, char sigil)
2307 {
2308     SV *sv;
2309     if (!gv) {
2310         sv_catpvs_nomg(out, "<NULLGV>");
2311         return;
2312     }
2313     sv = newSV(0);
2314     gv_fullname4(sv, gv, NULL, FALSE);
2315     Perl_sv_catpvf(aTHX_ out, "%c%-p", sigil, sv);
2316     SvREFCNT_dec_NN(sv);
2317 }
2318
2319 #ifdef USE_ITHREADS
2320 #  define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);
2321 #else
2322 #  define ITEM_SV(item) UNOP_AUX_item_sv(item)
2323 #endif
2324
2325
2326 /* return a temporary SV containing a stringified representation of
2327  * the op_aux field of a UNOP_AUX op, associated with CV cv
2328  */
2329
2330 SV*
2331 Perl_unop_aux_stringify(pTHX_ const OP *o, CV *cv)
2332 {
2333     UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2334     UV actions = items->uv;
2335     SV *sv;
2336     bool last = 0;
2337     bool is_hash = FALSE;
2338     int derefs = 0;
2339     SV *out = sv_2mortal(newSVpv("",0));
2340 #ifdef USE_ITHREADS
2341     PADLIST * const padlist = CvPADLIST(cv);
2342     PAD *comppad = comppad = PadlistARRAY(padlist)[1];
2343 #endif
2344
2345     PERL_ARGS_ASSERT_UNOP_AUX_STRINGIFY;
2346
2347     while (!last) {
2348         switch (actions & MDEREF_ACTION_MASK) {
2349
2350         case MDEREF_reload:
2351             actions = (++items)->uv;
2352             continue;
2353
2354         case MDEREF_HV_padhv_helem:
2355             is_hash = TRUE;
2356         case MDEREF_AV_padav_aelem:
2357             derefs = 1;
2358             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2359             goto do_elem;
2360
2361         case MDEREF_HV_gvhv_helem:
2362             is_hash = TRUE;
2363         case MDEREF_AV_gvav_aelem:
2364             derefs = 1;
2365             sv = ITEM_SV(++items);
2366             S_print_gv_name(aTHX_ (GV*)sv, out, '$');
2367             goto do_elem;
2368
2369         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2370             is_hash = TRUE;
2371         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2372             sv = ITEM_SV(++items);
2373             S_print_gv_name(aTHX_ (GV*)sv, out, '$');
2374             goto do_vivify_rv2xv_elem;
2375
2376         case MDEREF_HV_padsv_vivify_rv2hv_helem:
2377             is_hash = TRUE;
2378         case MDEREF_AV_padsv_vivify_rv2av_aelem:
2379             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2380             goto do_vivify_rv2xv_elem;
2381
2382         case MDEREF_HV_pop_rv2hv_helem:
2383         case MDEREF_HV_vivify_rv2hv_helem:
2384             is_hash = TRUE;
2385         do_vivify_rv2xv_elem:
2386         case MDEREF_AV_pop_rv2av_aelem:
2387         case MDEREF_AV_vivify_rv2av_aelem:
2388             if (!derefs++)
2389                 sv_catpvs_nomg(out, "->");
2390         do_elem:
2391             if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2392                 sv_catpvs_nomg(out, "->");
2393                 last = 1;
2394                 break;
2395             }
2396
2397             sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2398             switch (actions & MDEREF_INDEX_MASK) {
2399             case MDEREF_INDEX_const:
2400                 if (is_hash) {
2401                     STRLEN cur;
2402                     char *s;
2403                     sv = ITEM_SV(++items);
2404                     s = SvPV(sv, cur);
2405                     pv_pretty(out, s, cur, 30,
2406                                 NULL, NULL,
2407                                 (PERL_PV_PRETTY_NOCLEAR
2408                                 |PERL_PV_PRETTY_QUOTE
2409                                 |PERL_PV_PRETTY_ELLIPSES));
2410                 }
2411                 else
2412                     Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2413                 break;
2414             case MDEREF_INDEX_padsv:
2415                 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2416                 break;
2417             case MDEREF_INDEX_gvsv:
2418                 sv = ITEM_SV(++items);
2419                 S_print_gv_name(aTHX_ (GV*)sv, out, '$');
2420                 break;
2421             }
2422             sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2423
2424             if (actions & MDEREF_FLAG_last)
2425                 last = 1;
2426             is_hash = FALSE;
2427
2428             break;
2429
2430         default:
2431             PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2432                 (int)(actions & MDEREF_ACTION_MASK));
2433             last = 1;
2434             break;
2435
2436         } /* switch */
2437
2438         actions >>= MDEREF_SHIFT;
2439     } /* while */
2440     return out;
2441 }
2442
2443
2444 I32
2445 Perl_debop(pTHX_ const OP *o)
2446 {
2447     PERL_ARGS_ASSERT_DEBOP;
2448
2449     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2450         return 0;
2451
2452     Perl_deb(aTHX_ "%s", OP_NAME(o));
2453     switch (o->op_type) {
2454     case OP_CONST:
2455     case OP_HINTSEVAL:
2456         /* With ITHREADS, consts are stored in the pad, and the right pad
2457          * may not be active here, so check.
2458          * Looks like only during compiling the pads are illegal.
2459          */
2460 #ifdef USE_ITHREADS
2461         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2462 #endif
2463             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2464         break;
2465     case OP_GVSV:
2466     case OP_GV:
2467         if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2468             SV * const sv = newSV(0);
2469             gv_fullname3(sv, cGVOPo_gv, NULL);
2470             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2471             SvREFCNT_dec_NN(sv);
2472         }
2473         else if (cGVOPo_gv) {
2474             SV * const sv = newSV(0);
2475             assert(SvROK(cGVOPo_gv));
2476             assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2477             PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2478                     SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2479             SvREFCNT_dec_NN(sv);
2480         }
2481         else
2482             PerlIO_printf(Perl_debug_log, "(NULL)");
2483         break;
2484
2485     case OP_PADSV:
2486     case OP_PADAV:
2487     case OP_PADHV:
2488         S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2489         break;
2490
2491     case OP_PADRANGE:
2492         S_deb_padvar(aTHX_ o->op_targ,
2493                         o->op_private & OPpPADRANGE_COUNTMASK, 1);
2494         break;
2495
2496     case OP_MULTIDEREF:
2497         PerlIO_printf(Perl_debug_log, "(%-p)",
2498             unop_aux_stringify(o, deb_curcv(cxstack_ix)));
2499         break;
2500
2501     default:
2502         break;
2503     }
2504     PerlIO_printf(Perl_debug_log, "\n");
2505     return 0;
2506 }
2507
2508 STATIC CV*
2509 S_deb_curcv(pTHX_ const I32 ix)
2510 {
2511     const PERL_CONTEXT * const cx = &cxstack[ix];
2512     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2513         return cx->blk_sub.cv;
2514     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2515         return cx->blk_eval.cv;
2516     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2517         return PL_main_cv;
2518     else if (ix <= 0)
2519         return NULL;
2520     else
2521         return deb_curcv(ix - 1);
2522 }
2523
2524 void
2525 Perl_watch(pTHX_ char **addr)
2526 {
2527     PERL_ARGS_ASSERT_WATCH;
2528
2529     PL_watchaddr = addr;
2530     PL_watchok = *addr;
2531     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2532         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2533 }
2534
2535 STATIC void
2536 S_debprof(pTHX_ const OP *o)
2537 {
2538     PERL_ARGS_ASSERT_DEBPROF;
2539
2540     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2541         return;
2542     if (!PL_profiledata)
2543         Newxz(PL_profiledata, MAXO, U32);
2544     ++PL_profiledata[o->op_type];
2545 }
2546
2547 void
2548 Perl_debprofdump(pTHX)
2549 {
2550     unsigned i;
2551     if (!PL_profiledata)
2552         return;
2553     for (i = 0; i < MAXO; i++) {
2554         if (PL_profiledata[i])
2555             PerlIO_printf(Perl_debug_log,
2556                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2557                                        PL_op_name[i]);
2558     }
2559 }
2560
2561
2562 /*
2563  * Local variables:
2564  * c-indentation-style: bsd
2565  * c-basic-offset: 4
2566  * indent-tabs-mode: nil
2567  * End:
2568  *
2569  * ex: set ts=8 sts=4 sw=4 et:
2570  */