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