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 =for apidoc_section $display
  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     "PVOBJ",
  50 };
  51
  52
  53 static const char* const svshorttypenames[SVt_LAST] = {
  54     "UNDEF",
  55     "IV",
  56     "NV",
  57     "PV",
  58     "INVLST",
  59     "PVIV",
  60     "PVNV",
  61     "PVMG",
  62     "REGEXP",
  63     "GV",
  64     "PVLV",
  65     "AV",
  66     "HV",
  67     "CV",
  68     "FM",
  69     "IO",
  70     "OBJ",
  71 };
  72
  73 struct flag_to_name {
  74     U32 flag;
  75     const char *name;
  76 };
  77
  78 static void
  79 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
  80                const struct flag_to_name *const end)
  81 {
  82     do {
  83         if (flags & start->flag)
  84             sv_catpv(sv, start->name);
  85     } while (++start < end);
  86 }
  87
  88 #define append_flags(sv, f, flags) \
  89     S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
  90
  91 #define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
  92                               (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
  93                               PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
  94                               | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
  95
  96 #define _pv_display_for_dump(dsv, pv, cur, len, pvlim) \
  97     _pv_display_flags(aTHX_ dsv, pv, cur, len, pvlim, PERL_PV_ESCAPE_DWIM_ALL_HEX)
  98
  99 /*
 100 =for apidoc pv_escape
 101
 102 Escapes at most the first C<count> chars of C<pv> and puts the results into
 103 C<dsv> such that the size of the escaped string will not exceed C<max> chars
 104 and will not contain any incomplete escape sequences.  The number of bytes
 105 escaped will be returned in the C<STRLEN *escaped> parameter if it is not null.
 106 When the C<dsv> parameter is null no escaping actually occurs, but the number
 107 of bytes that would be escaped were it not null will be calculated.
 108
 109 If flags contains C<PERL_PV_ESCAPE_QUOTE> then any double quotes in the string
 110 will also be escaped.
 111
 112 Normally the SV will be cleared before the escaped string is prepared,
 113 but when C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur.
 114
 115 If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8.
 116 If C<PERL_PV_ESCAPE_UNI_DETECT> is set then the input string is scanned
 117 using C<is_utf8_string()> to determine if it is UTF-8.
 118
 119 If C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output
 120 using C<\x01F1> style escapes, otherwise if C<PERL_PV_ESCAPE_NONASCII>
 121 is set, only non-ASCII chars will be escaped using this style;
 122 otherwise, only chars above 255 will be so escaped; other non printable
 123 chars will use octal or common escaped patterns like C<\n>. Otherwise,
 124 if C<PERL_PV_ESCAPE_NOBACKSLASH> then all chars below 255 will be
 125 treated as printable and will be output as literals. The
 126 C<PERL_PV_ESCAPE_NON_WC> modifies the previous rules to cause word
 127 chars, unicode or otherwise, to be output as literals, note this uses
 128 the *unicode* rules for deciding on word characters.
 129
 130 If C<PERL_PV_ESCAPE_FIRSTCHAR> is set then only the first char of the
 131 string will be escaped, regardless of max. If the output is to be in
 132 hex, then it will be returned as a plain hex sequence. Thus the output
 133 will either be a single char, an octal escape sequence, a special escape
 134 like C<\n> or a hex value.
 135
 136 If C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a
 137 C<"%"> and not a C<"\\">. This is because regexes very often contain
 138 backslashed sequences, whereas C<"%"> is not a particularly common
 139 character in patterns.
 140
 141 Returns a pointer to the escaped text as held by C<dsv>.
 142
 143 =for apidoc Amnh||PERL_PV_ESCAPE_ALL
 144 =for apidoc Amnh||PERL_PV_ESCAPE_FIRSTCHAR
 145 =for apidoc Amnh||PERL_PV_ESCAPE_NOBACKSLASH
 146 =for apidoc Amnh||PERL_PV_ESCAPE_NOCLEAR
 147 =for apidoc Amnh||PERL_PV_ESCAPE_NONASCII
 148 =for apidoc Amnh||PERL_PV_ESCAPE_QUOTE
 149 =for apidoc Amnh||PERL_PV_ESCAPE_RE
 150 =for apidoc Amnh||PERL_PV_ESCAPE_UNI
 151 =for apidoc Amnh||PERL_PV_ESCAPE_UNI_DETECT
 152 =for apidoc Amnh||PERL_PV_ESCAPE_NON_WC
 153
 154 =cut
 155
 156 Unused or not for public use
 157 =for apidoc Cmnh||PERL_PV_PRETTY_REGPROP
 158 =for apidoc Cmnh||PERL_PV_PRETTY_DUMP
 159 =for apidoc Cmnh||PERL_PV_PRETTY_NOCLEAR
 160
 161 =cut
 162 */
 163 #define PV_ESCAPE_OCTBUFSIZE 32
 164
 165 #define PV_BYTE_HEX_UC  "x%02" UVXf
 166 #define PV_BYTE_HEX_LC  "x%02" UVxf
 167
 168 char *
 169 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
 170                 const STRLEN count, STRLEN max,
 171                 STRLEN * const escaped, U32 flags )
 172 {
 173
 174     bool use_uc_hex = false;
 175     if (flags & PERL_PV_ESCAPE_DWIM_ALL_HEX) {
 176         use_uc_hex = true;
 177         flags |= PERL_PV_ESCAPE_DWIM;
 178     }
 179
 180     const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
 181     const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
 182     const char *qs;
 183     const char *qe;
 184
 185     char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
 186     STRLEN wrote = 0;    /* chars written so far */
 187     STRLEN chsize = 0;   /* size of data to be written */
 188     STRLEN readsize = 1; /* size of data just read */
 189     bool isuni= (flags & PERL_PV_ESCAPE_UNI)
 190                 ? TRUE : FALSE; /* is this UTF-8 */
 191     const char *pv  = str;
 192     const char * const end = pv + count; /* end of string */
 193     const char *restart = NULL;
 194     STRLEN extra_len = 0;
 195     STRLEN tail = 0;
 196     if ((flags & PERL_PV_ESCAPE_TRUNC_MIDDLE) && max > 3) {
 197         if (flags & PERL_PV_ESCAPE_QUOTE) {
 198             qs = qe = "\"";
 199             extra_len = 5;
 200         } else if (flags & PERL_PV_PRETTY_LTGT) {
 201             qs = "<";
 202             qe = ">";
 203             extra_len = 5;
 204         } else {
 205             qs = qe = "";
 206             extra_len = 3;
 207         }
 208         tail = max / 2;
 209         restart = isuni ? (char *)utf8_hop_back((U8*)end,-tail,(U8*)pv) : end - tail;
 210         if (restart > pv) {
 211             max -= tail;
 212         } else {
 213             tail = 0;
 214             restart = NULL;
 215         }
 216     }
 217     else {
 218         qs = qe = "";
 219     }
 220
 221     octbuf[0] = esc;
 222
 223     PERL_ARGS_ASSERT_PV_ESCAPE;
 224
 225     if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
 226             /* This won't alter the UTF-8 flag */
 227             SvPVCLEAR(dsv);
 228     }
 229
 230     if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
 231         isuni = 1;
 232
 233     for ( ; pv < end ; pv += readsize ) {
 234         const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
 235         const U8 c = (U8)u;
 236         const char *source_buf = octbuf;
 237
 238         if ( ( u > 255 )
 239           || (flags & PERL_PV_ESCAPE_ALL)
 240           || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
 241         {
 242             if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
 243                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 244                                       "%" UVxf, u);
 245             else
 246             if ((flags & PERL_PV_ESCAPE_NON_WC) && isWORDCHAR_uvchr(u)) {
 247                 chsize = readsize;
 248                 source_buf = pv;
 249             }
 250             else
 251                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 252                                       ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
 253                                       ? ( use_uc_hex ? ("%c" PV_BYTE_HEX_UC) : ("%c" PV_BYTE_HEX_LC) )
 254                                       : "%cx{%02" UVxf "}", esc, u);
 255
 256         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
 257             chsize = 1;
 258         } else {
 259             if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
 260                 chsize = 2;
 261                 switch (c) {
 262
 263                 case '\\' : /* FALLTHROUGH */
 264                 case '%'  : if ( c == esc )  {
 265                                 octbuf[1] = esc;
 266                             } else {
 267                                 chsize = 1;
 268                             }
 269                             break;
 270                 case '\v' : octbuf[1] = 'v';  break;
 271                 case '\t' : octbuf[1] = 't';  break;
 272                 case '\r' : octbuf[1] = 'r';  break;
 273                 case '\n' : octbuf[1] = 'n';  break;
 274                 case '\f' : octbuf[1] = 'f';  break;
 275                 case '"'  :
 276                         if ( dq == '"' )
 277                                 octbuf[1] = '"';
 278                         else
 279                             chsize = 1;
 280                         break;
 281                 default:
 282                     if ( (flags & PERL_PV_ESCAPE_DWIM_ALL_HEX) || ((flags & PERL_PV_ESCAPE_DWIM) && c != '\0') ) {
 283                         chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 284                                       isuni ? "%cx{%02" UVxf "}" : ( use_uc_hex ? ("%c" PV_BYTE_HEX_UC) : ("%c" PV_BYTE_HEX_LC) ),
 285                                       esc, u);
 286                     }
 287                     else if ((pv+readsize < end) && isDIGIT((U8)*(pv+readsize)))
 288                         chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 289                                                   "%c%03o", esc, c);
 290                     else
 291                         chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 292                                                   "%c%o", esc, c);
 293                 }
 294             } else {
 295                 chsize = 1;
 296             }
 297         }
 298         if (max && (wrote + chsize > max)) {
 299             if (restart) {
 300                 /* this only happens with PERL_PV_ESCAPE_TRUNC_MIDDLE */
 301                 if (dsv)
 302                     Perl_sv_catpvf( aTHX_ dsv,"%s...%s", qe, qs);
 303                 wrote += extra_len;
 304                 pv = restart;
 305                 max = tail;
 306                 wrote = tail = 0;
 307                 restart = NULL;
 308             } else {
 309                 break;
 310             }
 311         } else if (chsize > 1) {
 312             if (dsv)
 313                 sv_catpvn(dsv, source_buf, chsize);
 314             wrote += chsize;
 315         } else {
 316             /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
 317                can be appended raw to the dsv. If dsv happens to be
 318                UTF-8 then we need catpvf to upgrade them for us.
 319                Or add a new API call sv_catpvc(). Think about that name, and
 320                how to keep it clear that it's unlike the s of catpvs, which is
 321                really an array of octets, not a string.  */
 322             if (dsv)
 323                 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
 324             wrote++;
 325         }
 326         if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
 327             break;
 328     }
 329     if (escaped != NULL)
 330         *escaped= pv - str;
 331     return dsv ? SvPVX(dsv) : NULL;
 332 }
 333 /*
 334 =for apidoc pv_pretty
 335
 336 Converts a string into something presentable, handling escaping via
 337 C<pv_escape()> and supporting quoting and ellipses.
 338
 339 If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be
 340 double quoted with any double quotes in the string escaped.  Otherwise
 341 if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
 342 angle brackets.
 343
 344 If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in
 345 string were output then an ellipsis C<...> will be appended to the
 346 string.  Note that this happens AFTER it has been quoted.
 347
 348 If C<start_color> is non-null then it will be inserted after the opening
 349 quote (if there is one) but before the escaped text.  If C<end_color>
 350 is non-null then it will be inserted after the escaped text but before
 351 any quotes or ellipses.
 352
 353 Returns a pointer to the prettified text as held by C<dsv>.
 354
 355 =for apidoc Amnh||PERL_PV_PRETTY_QUOTE
 356 =for apidoc Amnh||PERL_PV_PRETTY_LTGT
 357 =for apidoc Amnh||PERL_PV_PRETTY_ELLIPSES
 358
 359 =cut
 360 */
 361
 362 char *
 363 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
 364   const STRLEN max, char const * const start_color, char const * const end_color,
 365   const U32 flags )
 366 {
 367     const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
 368                              (flags & PERL_PV_PRETTY_LTGT)  ? "<>" : NULL);
 369     STRLEN escaped;
 370     STRLEN max_adjust= 0;
 371     STRLEN orig_cur;
 372
 373     PERL_ARGS_ASSERT_PV_PRETTY;
 374
 375     if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
 376         /* This won't alter the UTF-8 flag */
 377         SvPVCLEAR(dsv);
 378     }
 379     orig_cur= SvCUR(dsv);
 380
 381     if ( quotes )
 382         Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
 383
 384     if ( start_color != NULL )
 385         sv_catpv(dsv, start_color);
 386
 387     if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
 388         if (quotes)
 389             max_adjust += 2;
 390         assert(max > max_adjust);
 391         pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
 392         if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
 393             max_adjust += 3;
 394         assert(max > max_adjust);
 395     }
 396
 397     pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
 398
 399     if ( end_color != NULL )
 400         sv_catpv(dsv, end_color);
 401
 402     if ( quotes )
 403         Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
 404
 405     if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
 406             sv_catpvs(dsv, "...");
 407
 408     if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
 409         while( SvCUR(dsv) - orig_cur < max )
 410             sv_catpvs(dsv," ");
 411     }
 412
 413     return SvPVX(dsv);
 414 }
 415
 416 STATIC char *
 417 _pv_display_flags(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim, I32 pretty_flags)
 418 {
 419     PERL_ARGS_ASSERT_PV_DISPLAY;
 420
 421     pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP | pretty_flags );
 422     if (len > cur && pv[cur] == '\0')
 423             sv_catpvs( dsv, "\\0");
 424     return SvPVX(dsv);
 425 }
 426
 427 /*
 428 =for apidoc pv_display
 429
 430 Similar to
 431
 432   pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
 433
 434 except that an additional "\0" will be appended to the string when
 435 len > cur and pv[cur] is "\0".
 436
 437 Note that the final string may be up to 7 chars longer than pvlim.
 438
 439 =cut
 440 */
 441
 442 char *
 443 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
 444 {
 445     return _pv_display_flags(aTHX_ dsv, pv, cur, len, pvlim, 0);
 446 }
 447
 448 /*
 449 =for apidoc sv_peek
 450
 451 Implements C<SvPEEK>
 452
 453 =cut
 454 */
 455
 456 char *
 457 Perl_sv_peek(pTHX_ SV *sv)
 458 {
 459     SV * const t = sv_newmortal();
 460     int unref = 0;
 461     U32 type;
 462
 463     SvPVCLEAR(t);
 464   retry:
 465     if (!sv) {
 466         sv_catpvs(t, "VOID");
 467         goto finish;
 468     }
 469     else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
 470         /* detect data corruption under memory poisoning */
 471         sv_catpvs(t, "WILD");
 472         goto finish;
 473     }
 474     else if (  sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes
 475             || sv == &PL_sv_zero || sv == &PL_sv_placeholder)
 476     {
 477         if (sv == &PL_sv_undef) {
 478             sv_catpvs(t, "SV_UNDEF");
 479             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 480                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 481                 SvREADONLY(sv))
 482                 goto finish;
 483         }
 484         else if (sv == &PL_sv_no) {
 485             sv_catpvs(t, "SV_NO");
 486             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 487                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 488                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 489                                   SVp_POK|SVp_NOK)) &&
 490                 SvCUR(sv) == 0 &&
 491                 SvNVX(sv) == 0.0)
 492                 goto finish;
 493         }
 494         else if (sv == &PL_sv_yes) {
 495             sv_catpvs(t, "SV_YES");
 496             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 497                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 498                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 499                                   SVp_POK|SVp_NOK)) &&
 500                 SvCUR(sv) == 1 &&
 501                 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
 502                 SvNVX(sv) == 1.0)
 503                 goto finish;
 504         }
 505         else if (sv == &PL_sv_zero) {
 506             sv_catpvs(t, "SV_ZERO");
 507             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 508                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 509                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 510                                   SVp_POK|SVp_NOK)) &&
 511                 SvCUR(sv) == 1 &&
 512                 SvPVX_const(sv) && *SvPVX_const(sv) == '0' &&
 513                 SvNVX(sv) == 0.0)
 514                 goto finish;
 515         }
 516         else {
 517             sv_catpvs(t, "SV_PLACEHOLDER");
 518             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 519                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 520                 SvREADONLY(sv))
 521                 goto finish;
 522         }
 523         sv_catpvs(t, ":");
 524     }
 525     else if (SvREFCNT(sv) == 0) {
 526         sv_catpvs(t, "(");
 527         unref++;
 528     }
 529     else if (DEBUG_R_TEST_) {
 530         int is_tmp = 0;
 531         SSize_t ix;
 532         /* is this SV on the tmps stack? */
 533         for (ix=PL_tmps_ix; ix>=0; ix--) {
 534             if (PL_tmps_stack[ix] == sv) {
 535                 is_tmp = 1;
 536                 break;
 537             }
 538         }
 539         if (is_tmp || SvREFCNT(sv) > 1 || SvPADTMP(sv)) {
 540             Perl_sv_catpvf(aTHX_ t, "<");
 541             if (SvREFCNT(sv) > 1)
 542                 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv));
 543             if (SvPADTMP(sv))
 544                 Perl_sv_catpvf(aTHX_ t, "%s",  "P");
 545             if (is_tmp)
 546                 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
 547             Perl_sv_catpvf(aTHX_ t, ">");
 548         }
 549     }
 550
 551     if (SvROK(sv)) {
 552         sv_catpvs(t, "\\");
 553         if (SvCUR(t) + unref > 10) {
 554             SvCUR_set(t, unref + 3);
 555             *SvEND(t) = '\0';
 556             sv_catpvs(t, "...");
 557             goto finish;
 558         }
 559         sv = SvRV(sv);
 560         goto retry;
 561     }
 562     type = SvTYPE(sv);
 563     if (type == SVt_PVCV) {
 564         SV * const tmp = newSVpvs_flags("", SVs_TEMP);
 565         GV* gvcv = CvGV(sv);
 566         Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
 567                        ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
 568                        : "");
 569         goto finish;
 570     } else if (type < SVt_LAST) {
 571         sv_catpv(t, svshorttypenames[type]);
 572
 573         if (type == SVt_NULL)
 574             goto finish;
 575     } else {
 576         sv_catpvs(t, "FREED");
 577         goto finish;
 578     }
 579
 580     if (SvPOKp(sv)) {
 581         if (!SvPVX_const(sv))
 582             sv_catpvs(t, "(null)");
 583         else {
 584             SV * const tmp = newSVpvs("");
 585             sv_catpvs(t, "(");
 586             if (SvOOK(sv)) {
 587                 STRLEN delta;
 588                 SvOOK_offset(sv, delta);
 589                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
 590             }
 591             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
 592             if (SvUTF8(sv))
 593                 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
 594                                sv_uni_display(tmp, sv, 6 * SvCUR(sv),
 595                                               UNI_DISPLAY_QQ));
 596             SvREFCNT_dec_NN(tmp);
 597         }
 598     }
 599     else if (SvNOKp(sv)) {
 600         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
 601         STORE_LC_NUMERIC_SET_STANDARD();
 602         Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv));
 603         RESTORE_LC_NUMERIC();
 604     }
 605     else if (SvIOKp(sv)) {
 606         if (SvIsUV(sv))
 607             Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
 608         else
 609             Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv));
 610     }
 611     else
 612         sv_catpvs(t, "()");
 613
 614   finish:
 615     while (unref--)
 616         sv_catpvs(t, ")");
 617     if (TAINTING_get && sv && SvTAINTED(sv))
 618         sv_catpvs(t, " [tainted]");
 619     return SvPV_nolen(t);
 620 }
 621
 622 void
 623 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
 624 {
 625     va_list args;
 626     PERL_ARGS_ASSERT_DUMP_INDENT;
 627     va_start(args, pat);
 628     dump_vindent(level, file, pat, &args);
 629     va_end(args);
 630 }
 631
 632 void
 633 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
 634 {
 635     PERL_ARGS_ASSERT_DUMP_VINDENT;
 636     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
 637     PerlIO_vprintf(file, pat, *args);
 638 }
 639
 640
 641 /* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar
 642  * for each indent level as appropriate.
 643  *
 644  * bar contains bits indicating which indent columns should have a
 645  * vertical bar displayed. Bit 0 is the RH-most column. If there are more
 646  * levels than bits in bar, then the first few indents are displayed
 647  * without a bar.
 648  *
 649  * The start of a new op is signalled by passing a value for level which
 650  * has been negated and offset by 1 (so that level 0 is passed as -1 and
 651  * can thus be distinguished from -0); in this case, emit a suitably
 652  * indented blank line, then on the next line, display the op's sequence
 653  * number, and make the final indent an '+----'.
 654  *
 655  * e.g.
 656  *
 657  *      |   FOO       # level = 1,   bar = 0b1
 658  *      |   |         # level =-2-1, bar = 0b11
 659  * 1234 |   +---BAR
 660  *      |       BAZ   # level = 2,   bar = 0b10
 661  */
 662
 663 static void
 664 S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
 665                 const char* pat, ...)
 666 {
 667     va_list args;
 668     I32 i;
 669     bool newop = (level < 0);
 670
 671     va_start(args, pat);
 672
 673     /* start displaying a new op? */
 674     if (newop) {
 675         UV seq = sequence_num(o);
 676
 677         level = -level - 1;
 678
 679         /* output preceding blank line */
 680         PerlIO_puts(file, "     ");
 681         for (i = level-1; i >= 0; i--)
 682             PerlIO_puts(file,  (   i == 0
 683                                 || (i < UVSIZE*8 && (bar & ((UV)1 << i)))
 684                                )
 685                                     ?  "|   " : "    ");
 686         PerlIO_puts(file, "\n");
 687
 688         /* output sequence number */
 689         if (seq)
 690             PerlIO_printf(file, "%-4" UVuf " ", seq);
 691         else
 692             PerlIO_puts(file, "???? ");
 693
 694     }
 695     else
 696         PerlIO_printf(file, "     ");
 697
 698     for (i = level-1; i >= 0; i--)
 699             PerlIO_puts(file,
 700                   (i == 0 && newop) ? "+--"
 701                 : (bar & (1 << i))  ? "|   "
 702                 :                     "    ");
 703     PerlIO_vprintf(file, pat, args);
 704     va_end(args);
 705 }
 706
 707
 708 /* display a link field (e.g. op_next) in the format
 709  *     ====> sequence_number [opname 0x123456]
 710  */
 711
 712 static void
 713 S_opdump_link(pTHX_ const OP *base, const OP *o, PerlIO *file)
 714 {
 715     PerlIO_puts(file, " ===> ");
 716     if (o == base)
 717         PerlIO_puts(file, "[SELF]\n");
 718     else if (o)
 719         PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
 720             sequence_num(o), OP_NAME(o), PTR2UV(o));
 721     else
 722         PerlIO_puts(file, "[0x0]\n");
 723 }
 724
 725 /*
 726 =for apidoc_section $debugging
 727 =for apidoc dump_all
 728
 729 Dumps the entire optree of the current program starting at C<PL_main_root> to
 730 C<STDERR>.  Also dumps the optrees for all visible subroutines in
 731 C<PL_defstash>.
 732
 733 =cut
 734 */
 735
 736 void
 737 Perl_dump_all(pTHX)
 738 {
 739     dump_all_perl(FALSE);
 740 }
 741
 742 void
 743 Perl_dump_all_perl(pTHX_ bool justperl)
 744 {
 745     PerlIO_setlinebuf(Perl_debug_log);
 746     if (PL_main_root)
 747         op_dump(PL_main_root);
 748     dump_packsubs_perl(PL_defstash, justperl);
 749 }
 750
 751 /*
 752 =for apidoc dump_packsubs
 753
 754 Dumps the optrees for all visible subroutines in C<stash>.
 755
 756 =cut
 757 */
 758
 759 void
 760 Perl_dump_packsubs(pTHX_ const HV *stash)
 761 {
 762     PERL_ARGS_ASSERT_DUMP_PACKSUBS;
 763     dump_packsubs_perl(stash, FALSE);
 764 }
 765
 766 void
 767 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
 768 {
 769     I32 i;
 770
 771     PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
 772
 773     if (!HvTOTALKEYS(stash))
 774         return;
 775     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 776         const HE *entry;
 777         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 778             GV * gv = (GV *)HeVAL(entry);
 779             if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
 780                 /* unfake a fake GV */
 781                 (void)CvGV(SvRV(gv));
 782             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 783                 continue;
 784             if (GvCVu(gv))
 785                 dump_sub_perl(gv, justperl);
 786             if (GvFORM(gv))
 787                 dump_form(gv);
 788             if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
 789                 const HV * const hv = GvHV(gv);
 790                 if (hv && (hv != PL_defstash))
 791                     dump_packsubs_perl(hv, justperl); /* nested package */
 792             }
 793         }
 794     }
 795 }
 796
 797 void
 798 Perl_dump_sub(pTHX_ const GV *gv)
 799 {
 800     PERL_ARGS_ASSERT_DUMP_SUB;
 801     dump_sub_perl(gv, FALSE);
 802 }
 803
 804 void
 805 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
 806 {
 807     CV *cv;
 808
 809     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
 810
 811     cv = isGV_with_GP(gv) ? GvCV(gv) : CV_FROM_REF((SV*)gv);
 812     if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
 813         return;
 814
 815     if (isGV_with_GP(gv)) {
 816         SV * const namesv = newSVpvs_flags("", SVs_TEMP);
 817         SV *escsv = newSVpvs_flags("", SVs_TEMP);
 818         const char *namepv;
 819         STRLEN namelen;
 820         gv_fullname3(namesv, gv, NULL);
 821         namepv = SvPV_const(namesv, namelen);
 822         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
 823                      generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
 824     } else {
 825         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
 826     }
 827     if (CvISXSUB(cv))
 828         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
 829             PTR2UV(CvXSUB(cv)),
 830             (int)CvXSUBANY(cv).any_i32);
 831     else if (CvROOT(cv))
 832         op_dump(CvROOT(cv));
 833     else
 834         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 835 }
 836
 837 /*
 838 =for apidoc dump_form
 839
 840 Dumps the contents of the format contained in the GV C<gv> to C<STDERR>, or a
 841 message that one doesn't exist.
 842
 843 =cut
 844 */
 845
 846 void
 847 Perl_dump_form(pTHX_ const GV *gv)
 848 {
 849     SV * const sv = sv_newmortal();
 850
 851     PERL_ARGS_ASSERT_DUMP_FORM;
 852
 853     gv_fullname3(sv, gv, NULL);
 854     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
 855     if (CvROOT(GvFORM(gv)))
 856         op_dump(CvROOT(GvFORM(gv)));
 857     else
 858         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 859 }
 860
 861 void
 862 Perl_dump_eval(pTHX)
 863 {
 864     op_dump(PL_eval_root);
 865 }
 866
 867
 868 /* returns a temp SV displaying the name of a GV. Handles the case where
 869  * a GV is in fact a ref to a CV */
 870
 871 static SV *
 872 S_gv_display(pTHX_ GV *gv)
 873 {
 874     SV * const name = newSVpvs_flags("", SVs_TEMP);
 875     if (gv) {
 876         SV * const raw = newSVpvs_flags("", SVs_TEMP);
 877         STRLEN len;
 878         const char * rawpv;
 879
 880         if (isGV_with_GP(gv))
 881             gv_fullname3(raw, gv, NULL);
 882         else {
 883             Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
 884                     SvPV_nolen_const(cv_name(CV_FROM_REF((SV*)gv), name, 0)));
 885         }
 886         rawpv = SvPV_const(raw, len);
 887         generic_pv_escape(name, rawpv, len, SvUTF8(raw));
 888     }
 889     else
 890         sv_catpvs(name, "(NULL)");
 891
 892     return name;
 893 }
 894
 895
 896
 897 /* forward decl */
 898 static void
 899 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
 900
 901
 902 static void
 903 S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
 904 {
 905     UV kidbar;
 906
 907     if (!pm)
 908         return;
 909
 910     kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
 911
 912     if (PM_GETRE(pm)) {
 913         char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
 914         S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
 915              ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
 916     }
 917     else
 918         S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
 919
 920     if (pm->op_pmflags || PM_GETRE(pm)) {
 921         SV * const tmpsv = pm_description(pm);
 922         S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
 923                         SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 924         SvREFCNT_dec_NN(tmpsv);
 925     }
 926
 927     if (pm->op_type == OP_SPLIT)
 928         S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
 929                     "TARGOFF/GV = 0x%" UVxf "\n",
 930                     PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
 931     else {
 932         if (pm->op_pmreplrootu.op_pmreplroot) {
 933             S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
 934             S_do_op_dump_bar(aTHX_ level + 2,
 935                 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
 936                 file, pm->op_pmreplrootu.op_pmreplroot);
 937         }
 938     }
 939
 940     if (pm->op_code_list) {
 941         if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
 942             S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
 943             S_do_op_dump_bar(aTHX_ level + 2,
 944                             (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
 945                             file, pm->op_code_list);
 946         }
 947         else
 948             S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
 949                         "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
 950     }
 951 }
 952
 953
 954 void
 955 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
 956 {
 957     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
 958     S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
 959 }
 960
 961
 962 const struct flag_to_name pmflags_flags_names[] = {
 963     {PMf_CONST, ",CONST"},
 964     {PMf_KEEP, ",KEEP"},
 965     {PMf_GLOBAL, ",GLOBAL"},
 966     {PMf_CONTINUE, ",CONTINUE"},
 967     {PMf_RETAINT, ",RETAINT"},
 968     {PMf_EVAL, ",EVAL"},
 969     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
 970     {PMf_HAS_CV, ",HAS_CV"},
 971     {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
 972     {PMf_IS_QR, ",IS_QR"}
 973 };
 974
 975 static SV *
 976 S_pm_description(pTHX_ const PMOP *pm)
 977 {
 978     SV * const desc = newSVpvs("");
 979     const REGEXP * const regex = PM_GETRE(pm);
 980     const U32 pmflags = pm->op_pmflags;
 981
 982     PERL_ARGS_ASSERT_PM_DESCRIPTION;
 983
 984     if (pmflags & PMf_ONCE)
 985         sv_catpvs(desc, ",ONCE");
 986 #ifdef USE_ITHREADS
 987     if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
 988         sv_catpvs(desc, ":USED");
 989 #else
 990     if (pmflags & PMf_USED)
 991         sv_catpvs(desc, ":USED");
 992 #endif
 993
 994     if (regex) {
 995         if (RX_ISTAINTED(regex))
 996             sv_catpvs(desc, ",TAINTED");
 997         if (RX_CHECK_SUBSTR(regex)) {
 998             if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
 999                 sv_catpvs(desc, ",SCANFIRST");
1000             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
1001                 sv_catpvs(desc, ",ALL");
1002         }
1003         if (RX_EXTFLAGS(regex) & RXf_START_ONLY)
1004             sv_catpvs(desc, ",START_ONLY");
1005         if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
1006             sv_catpvs(desc, ",SKIPWHITE");
1007         if (RX_EXTFLAGS(regex) & RXf_WHITE)
1008             sv_catpvs(desc, ",WHITE");
1009         if (RX_EXTFLAGS(regex) & RXf_NULL)
1010             sv_catpvs(desc, ",NULL");
1011     }
1012
1013     append_flags(desc, pmflags, pmflags_flags_names);
1014     return desc;
1015 }
1016
1017 /*
1018 =for apidoc pmop_dump
1019
1020 Dump an OP that is related to Pattern Matching, such as C<s/foo/bar/>; these require
1021 special handling.
1022
1023 =cut
1024 */
1025
1026 void
1027 Perl_pmop_dump(pTHX_ PMOP *pm)
1028 {
1029     do_pmop_dump(0, Perl_debug_log, pm);
1030 }
1031
1032 /* Return a unique integer to represent the address of op o.
1033  * If it already exists in PL_op_sequence, just return it;
1034  * otherwise add it.
1035  *  *** Note that this isn't thread-safe */
1036
1037 STATIC UV
1038 S_sequence_num(pTHX_ const OP *o)
1039 {
1040     SV     *op,
1041           **seq;
1042     const char *key;
1043     STRLEN  len;
1044     if (!o)
1045         return 0;
1046     op = newSVuv(PTR2UV(o));
1047     sv_2mortal(op);
1048     key = SvPV_const(op, len);
1049     if (!PL_op_sequence)
1050         PL_op_sequence = newHV();
1051     seq = hv_fetch(PL_op_sequence, key, len, TRUE);
1052     if (SvOK(*seq))
1053         return SvUV(*seq);
1054     sv_setuv(*seq, ++PL_op_seq);
1055     return PL_op_seq;
1056 }
1057
1058
1059
1060
1061
1062 const struct flag_to_name op_flags_names[] = {
1063     {OPf_KIDS, ",KIDS"},
1064     {OPf_PARENS, ",PARENS"},
1065     {OPf_REF, ",REF"},
1066     {OPf_MOD, ",MOD"},
1067     {OPf_STACKED, ",STACKED"},
1068     {OPf_SPECIAL, ",SPECIAL"}
1069 };
1070
1071
1072 /* indexed by enum OPclass */
1073 const char * const op_class_names[] = {
1074     "NULL",
1075     "OP",
1076     "UNOP",
1077     "BINOP",
1078     "LOGOP",
1079     "LISTOP",
1080     "PMOP",
1081     "SVOP",
1082     "PADOP",
1083     "PVOP",
1084     "LOOP",
1085     "COP",
1086     "METHOP",
1087     "UNOP_AUX",
1088 };
1089
1090
1091 /* dump an op and any children. level indicates the initial indent.
1092  * The bits of bar indicate which indents should receive a vertical bar.
1093  * For example if level == 5 and bar == 0b01101, then the indent prefix
1094  * emitted will be (not including the <>'s):
1095  *
1096  *   <    |   |       |   >
1097  *    55554444333322221111
1098  *
1099  * For heavily nested output, the level may exceed the number of bits
1100  * in bar; in this case the first few columns in the output will simply
1101  * not have a bar, which is harmless.
1102  */
1103
1104 static void
1105 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
1106 {
1107     const OPCODE optype = o->op_type;
1108
1109     PERL_ARGS_ASSERT_DO_OP_DUMP;
1110
1111     /* print op header line */
1112
1113     S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
1114
1115     if (optype == OP_NULL && o->op_targ)
1116         PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
1117
1118     PerlIO_printf(file, " %s(0x%" UVxf ")",
1119                     op_class_names[op_class(o)], PTR2UV(o));
1120     S_opdump_link(aTHX_ o, o->op_next, file);
1121
1122     /* print op common fields */
1123
1124     if (level == 0) {
1125         S_opdump_indent(aTHX_ o, level, bar, file, "PARENT");
1126         S_opdump_link(aTHX_ o, op_parent((OP*)o), file);
1127     }
1128     else if (!OpHAS_SIBLING(o)) {
1129         bool ok = TRUE;
1130         OP *p = o->op_sibparent;
1131         if (!p || !(p->op_flags & OPf_KIDS))
1132             ok = FALSE;
1133         else {
1134             OP *kid = cUNOPx(p)->op_first;
1135             while (kid != o) {
1136                 kid = OpSIBLING(kid);
1137                 if (!kid) {
1138                     ok = FALSE;
1139                     break;
1140                 }
1141             }
1142         }
1143         if (!ok) {
1144             S_opdump_indent(aTHX_ o, level, bar, file,
1145                             "*** WILD PARENT 0x%p\n", p);
1146         }
1147     }
1148
1149     if (o->op_targ && optype != OP_NULL)
1150             S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
1151                 (long)o->op_targ);
1152
1153     if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
1154         SV * const tmpsv = newSVpvs("");
1155         switch (o->op_flags & OPf_WANT) {
1156         case OPf_WANT_VOID:
1157             sv_catpvs(tmpsv, ",VOID");
1158             break;
1159         case OPf_WANT_SCALAR:
1160             sv_catpvs(tmpsv, ",SCALAR");
1161             break;
1162         case OPf_WANT_LIST:
1163             sv_catpvs(tmpsv, ",LIST");
1164             break;
1165         default:
1166             sv_catpvs(tmpsv, ",UNKNOWN");
1167             break;
1168         }
1169         append_flags(tmpsv, o->op_flags, op_flags_names);
1170         if (o->op_slabbed)  sv_catpvs(tmpsv, ",SLABBED");
1171         if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
1172         if (o->op_static)   sv_catpvs(tmpsv, ",STATIC");
1173         if (o->op_folded)   sv_catpvs(tmpsv, ",FOLDED");
1174         if (o->op_moresib)  sv_catpvs(tmpsv, ",MORESIB");
1175         S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
1176                          SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1177     }
1178
1179     if (o->op_private) {
1180         U16 oppriv = o->op_private;
1181         I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
1182         SV * tmpsv = NULL;
1183
1184         if (op_ix != -1) {
1185             U16 stop = 0;
1186             tmpsv = newSVpvs("");
1187             for (; !stop; op_ix++) {
1188                 U16 entry = PL_op_private_bitdefs[op_ix];
1189                 U16 bit = (entry >> 2) & 7;
1190                 U16 ix = entry >> 5;
1191
1192                 stop = (entry & 1);
1193
1194                 if (entry & 2) {
1195                     /* bitfield */
1196                     I16 const *p = &PL_op_private_bitfields[ix];
1197                     U16 bitmin = (U16) *p++;
1198                     I16 label = *p++;
1199                     I16 enum_label;
1200                     U16 mask = 0;
1201                     U16 i;
1202                     U16 val;
1203
1204                     for (i = bitmin; i<= bit; i++)
1205                         mask |= (1<<i);
1206                     bit = bitmin;
1207                     val = (oppriv & mask);
1208
1209                     if (   label != -1
1210                         && PL_op_private_labels[label] == '-'
1211                         && PL_op_private_labels[label+1] == '\0'
1212                     )
1213                         /* display as raw number */
1214                         continue;
1215
1216                     oppriv -= val;
1217                     val >>= bit;
1218                     enum_label = -1;
1219                     while (*p != -1) {
1220                         if (val == *p++) {
1221                             enum_label = *p;
1222                             break;
1223                         }
1224                         p++;
1225                     }
1226                     if (val == 0 && enum_label == -1)
1227                         /* don't display anonymous zero values */
1228                         continue;
1229
1230                     sv_catpvs(tmpsv, ",");
1231                     if (label != -1) {
1232                         sv_catpv(tmpsv, &PL_op_private_labels[label]);
1233                         sv_catpvs(tmpsv, "=");
1234                     }
1235                     if (enum_label == -1)
1236                         Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
1237                     else
1238                         sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
1239
1240                 }
1241                 else {
1242                     /* bit flag */
1243                     if (   oppriv & (1<<bit)
1244                         && !(PL_op_private_labels[ix] == '-'
1245                              && PL_op_private_labels[ix+1] == '\0'))
1246                     {
1247                         oppriv -= (1<<bit);
1248                         sv_catpvs(tmpsv, ",");
1249                         sv_catpv(tmpsv, &PL_op_private_labels[ix]);
1250                     }
1251                 }
1252             }
1253             if (oppriv) {
1254                 sv_catpvs(tmpsv, ",");
1255                 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
1256             }
1257         }
1258         if (tmpsv && SvCUR(tmpsv)) {
1259             S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
1260                             SvPVX_const(tmpsv) + 1);
1261         } else
1262             S_opdump_indent(aTHX_ o, level, bar, file,
1263                             "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
1264     }
1265
1266     switch (optype) {
1267     case OP_AELEMFAST:
1268     case OP_GVSV:
1269     case OP_GV:
1270 #ifdef USE_ITHREADS
1271         S_opdump_indent(aTHX_ o, level, bar, file,
1272                         "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1273 #else
1274         S_opdump_indent(aTHX_ o, level, bar, file,
1275             "GV = %" SVf " (0x%" UVxf ")\n",
1276             SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
1277 #endif
1278         break;
1279
1280     case OP_MULTIDEREF:
1281     {
1282         UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1283         UV i, count = items[-1].uv;
1284
1285         S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
1286         for (i=0; i < count;  i++)
1287             S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1288                                     "%" UVuf " => 0x%" UVxf "\n",
1289                                     i, items[i].uv);
1290         break;
1291     }
1292
1293     case OP_MULTICONCAT:
1294         S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n",
1295             (IV)cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].ssize);
1296         /* XXX really ought to dump each field individually,
1297          * but that's too much like hard work */
1298         S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n",
1299             SVfARG(multiconcat_stringify(o)));
1300         break;
1301
1302     case OP_CONST:
1303     case OP_HINTSEVAL:
1304     case OP_METHOD_NAMED:
1305     case OP_METHOD_SUPER:
1306     case OP_METHOD_REDIR:
1307     case OP_METHOD_REDIR_SUPER:
1308 #ifndef USE_ITHREADS
1309         /* with ITHREADS, consts are stored in the pad, and the right pad
1310          * may not be active here, so skip */
1311         S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
1312                         SvPEEK(cMETHOPo_meth));
1313 #endif
1314         break;
1315     case OP_NULL:
1316         if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1317             break;
1318         /* FALLTHROUGH */
1319     case OP_NEXTSTATE:
1320     case OP_DBSTATE:
1321         if (CopLINE(cCOPo))
1322             S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" LINE_Tf "\n",
1323                             CopLINE(cCOPo));
1324
1325         if (CopSTASHPV(cCOPo)) {
1326             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1327             HV *stash = CopSTASH(cCOPo);
1328             const char * const hvname = HvNAME_get(stash);
1329
1330             S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
1331                                generic_pv_escape(tmpsv, hvname,
1332                                   HvNAMELEN(stash), HvNAMEUTF8(stash)));
1333         }
1334
1335         if (CopLABEL(cCOPo)) {
1336             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1337             STRLEN label_len;
1338             U32 label_flags;
1339             const char *label = CopLABEL_len_flags(cCOPo,
1340                                                      &label_len, &label_flags);
1341             S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1342                                 generic_pv_escape( tmpsv, label, label_len,
1343                                            (label_flags & SVf_UTF8)));
1344         }
1345         /* add hints and features if set */
1346         if (cCOPo->cop_hints)
1347             S_opdump_indent(aTHX_ o, level, bar, file, "HINTS = %08x\n",cCOPo->cop_hints);
1348         if (cCOPo->cop_features)
1349             S_opdump_indent(aTHX_ o, level, bar, file, "FEATS = %08x\n",cCOPo->cop_features);
1350
1351         S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
1352                          (unsigned int)cCOPo->cop_seq);
1353         break;
1354
1355     case OP_ENTERITER:
1356     case OP_ENTERLOOP:
1357         S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
1358         S_opdump_link(aTHX_ o, cLOOPo->op_redoop, file);
1359         S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
1360         S_opdump_link(aTHX_ o, cLOOPo->op_nextop, file);
1361         S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
1362         S_opdump_link(aTHX_ o, cLOOPo->op_lastop, file);
1363         break;
1364
1365     case OP_REGCOMP:
1366     case OP_SUBSTCONT:
1367     case OP_COND_EXPR:
1368     case OP_RANGE:
1369     case OP_MAPWHILE:
1370     case OP_GREPWHILE:
1371     case OP_OR:
1372     case OP_DOR:
1373     case OP_AND:
1374     case OP_ORASSIGN:
1375     case OP_DORASSIGN:
1376     case OP_ANDASSIGN:
1377     case OP_ARGDEFELEM:
1378     case OP_ENTERGIVEN:
1379     case OP_ENTERWHEN:
1380     case OP_ENTERTRY:
1381     case OP_ONCE:
1382         S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
1383         S_opdump_link(aTHX_ o, cLOGOPo->op_other, file);
1384         break;
1385     case OP_SPLIT:
1386     case OP_MATCH:
1387     case OP_QR:
1388     case OP_SUBST:
1389         S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
1390         break;
1391     case OP_LEAVE:
1392     case OP_LEAVEEVAL:
1393     case OP_LEAVESUB:
1394     case OP_LEAVESUBLV:
1395     case OP_LEAVEWRITE:
1396     case OP_SCOPE:
1397         if (o->op_private & OPpREFCOUNTED)
1398             S_opdump_indent(aTHX_ o, level, bar, file,
1399                             "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1400         break;
1401
1402     case OP_DUMP:
1403     case OP_GOTO:
1404     case OP_NEXT:
1405     case OP_LAST:
1406     case OP_REDO:
1407         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1408             break;
1409         {
1410             SV * const label = newSVpvs_flags("", SVs_TEMP);
1411             generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
1412             S_opdump_indent(aTHX_ o, level, bar, file,
1413                             "PV = \"%" SVf "\" (0x%" UVxf ")\n",
1414                             SVfARG(label), PTR2UV(cPVOPo->op_pv));
1415             break;
1416         }
1417
1418     case OP_TRANS:
1419     case OP_TRANSR:
1420         if (o->op_private & OPpTRANS_USE_SVOP) {
1421             /* utf8: table stored as an inversion map */
1422 #ifndef USE_ITHREADS
1423         /* with ITHREADS, it is stored in the pad, and the right pad
1424          * may not be active here, so skip */
1425             S_opdump_indent(aTHX_ o, level, bar, file,
1426                             "INVMAP = 0x%" UVxf "\n",
1427                             PTR2UV(MUTABLE_SV(cSVOPo->op_sv)));
1428 #endif
1429         }
1430         else {
1431             const OPtrans_map * const tbl = (OPtrans_map*)cPVOPo->op_pv;
1432             SSize_t i, size = tbl->size;
1433
1434             S_opdump_indent(aTHX_ o, level, bar, file,
1435                             "TABLE = 0x%" UVxf "\n",
1436                             PTR2UV(tbl));
1437             S_opdump_indent(aTHX_ o, level, bar, file,
1438                 "  SIZE: 0x%" UVxf "\n", (UV)size);
1439
1440             /* dump size+1 values, to include the extra slot at the end */
1441             for (i = 0; i <= size; i++) {
1442                 short val = tbl->map[i];
1443                 if ((i & 0xf) == 0)
1444                     S_opdump_indent(aTHX_ o, level, bar, file,
1445                         " %4" UVxf ":", (UV)i);
1446                 if (val < 0)
1447                     PerlIO_printf(file, " %2"  IVdf, (IV)val);
1448                 else
1449                     PerlIO_printf(file, " %02" UVxf, (UV)val);
1450
1451                 if ( i == size || (i & 0xf) == 0xf)
1452                     PerlIO_printf(file, "\n");
1453             }
1454         }
1455         break;
1456
1457
1458     default:
1459         break;
1460     }
1461     if (o->op_flags & OPf_KIDS) {
1462         OP *kid;
1463         level++;
1464         bar <<= 1;
1465         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1466             S_do_op_dump_bar(aTHX_ level,
1467                             (bar | cBOOL(OpHAS_SIBLING(kid))),
1468                             file, kid);
1469     }
1470 }
1471
1472
1473 void
1474 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1475 {
1476     S_do_op_dump_bar(aTHX_ level, 0, file, o);
1477 }
1478
1479
1480 /*
1481 =for apidoc op_dump
1482
1483 Dumps the optree starting at OP C<o> to C<STDERR>.
1484
1485 =cut
1486 */
1487
1488 void
1489 Perl_op_dump(pTHX_ const OP *o)
1490 {
1491     PERL_ARGS_ASSERT_OP_DUMP;
1492     do_op_dump(0, Perl_debug_log, o);
1493 }
1494
1495 /*
1496 =for apidoc gv_dump
1497
1498 Dump the name and, if they differ, the effective name of the GV C<gv> to
1499 C<STDERR>.
1500
1501 =cut
1502 */
1503
1504 void
1505 Perl_gv_dump(pTHX_ GV *gv)
1506 {
1507     STRLEN len;
1508     const char* name;
1509     SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1510
1511     if (!gv) {
1512         PerlIO_printf(Perl_debug_log, "{}\n");
1513         return;
1514     }
1515     sv = sv_newmortal();
1516     PerlIO_printf(Perl_debug_log, "{\n");
1517     gv_fullname3(sv, gv, NULL);
1518     name = SvPV_const(sv, len);
1519     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1520                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1521     if (gv != GvEGV(gv)) {
1522         gv_efullname3(sv, GvEGV(gv), NULL);
1523         name = SvPV_const(sv, len);
1524         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1525                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1526     }
1527     (void)PerlIO_putc(Perl_debug_log, '\n');
1528     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1529 }
1530
1531
1532 /* map magic types to the symbolic names
1533  * (with the PERL_MAGIC_ prefixed stripped)
1534  */
1535
1536 static const struct { const char type; const char *name; } magic_names[] = {
1537 #include "mg_names.inc"
1538         /* this null string terminates the list */
1539         { 0,                         NULL },
1540 };
1541
1542 void
1543 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1544 {
1545     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1546
1547     for (; mg; mg = mg->mg_moremagic) {
1548         Perl_dump_indent(aTHX_ level, file,
1549                          "  MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
1550         if (mg->mg_virtual) {
1551             const MGVTBL * const v = mg->mg_virtual;
1552             if (v >= PL_magic_vtables
1553                 && v < PL_magic_vtables + magic_vtable_max) {
1554                 const U32 i = v - PL_magic_vtables;
1555                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1556             }
1557             else
1558                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"
1559                                        UVxf "\n", PTR2UV(v));
1560         }
1561         else
1562             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1563
1564         if (mg->mg_private)
1565             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1566
1567         {
1568             int n;
1569             const char *name = NULL;
1570             for (n = 0; magic_names[n].name; n++) {
1571                 if (mg->mg_type == magic_names[n].type) {
1572                     name = magic_names[n].name;
1573                     break;
1574                 }
1575             }
1576             if (name)
1577                 Perl_dump_indent(aTHX_ level, file,
1578                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1579             else
1580                 Perl_dump_indent(aTHX_ level, file,
1581                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1582         }
1583
1584         if (mg->mg_flags) {
1585             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1586             if (mg->mg_type == PERL_MAGIC_envelem &&
1587                 mg->mg_flags & MGf_TAINTEDDIR)
1588                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1589             if (mg->mg_type == PERL_MAGIC_regex_global &&
1590                 mg->mg_flags & MGf_MINMATCH)
1591                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1592             if (mg->mg_flags & MGf_REFCOUNTED)
1593                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1594             if (mg->mg_flags & MGf_GSKIP)
1595                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1596             if (mg->mg_flags & MGf_COPY)
1597                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1598             if (mg->mg_flags & MGf_DUP)
1599                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1600             if (mg->mg_flags & MGf_LOCAL)
1601                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1602             if (mg->mg_type == PERL_MAGIC_regex_global &&
1603                 mg->mg_flags & MGf_BYTES)
1604                 Perl_dump_indent(aTHX_ level, file, "      BYTES\n");
1605         }
1606         if (mg->mg_obj) {
1607             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%" UVxf "\n",
1608                 PTR2UV(mg->mg_obj));
1609             if (mg->mg_type == PERL_MAGIC_qr) {
1610                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1611                 SV * const dsv = sv_newmortal();
1612                 const char * const s
1613                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1614                     60, NULL, NULL,
1615                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1616                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1617                 );
1618                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1619                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %" IVdf "\n",
1620                         (IV)RX_REFCNT(re));
1621             }
1622             if (mg->mg_flags & MGf_REFCOUNTED)
1623                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1624         }
1625         if (mg->mg_len)
1626             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1627         if (mg->mg_ptr) {
1628             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1629             if (mg->mg_len >= 0) {
1630                 if (mg->mg_type != PERL_MAGIC_utf8) {
1631                     SV * const sv = newSVpvs("");
1632                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1633                     SvREFCNT_dec_NN(sv);
1634                 }
1635             }
1636             else if (mg->mg_len == HEf_SVKEY) {
1637                 PerlIO_puts(file, " => HEf_SVKEY\n");
1638                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1639                            maxnest, dumpops, pvlim); /* MG is already +1 */
1640                 continue;
1641             }
1642             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1643             else
1644                 PerlIO_puts(
1645                   file,
1646                  " ???? - " __FILE__
1647                  " does not know how to handle this MG_LEN"
1648                 );
1649             (void)PerlIO_putc(file, '\n');
1650         }
1651         if (mg->mg_type == PERL_MAGIC_utf8) {
1652             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1653             if (cache) {
1654                 IV i;
1655                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1656                     Perl_dump_indent(aTHX_ level, file,
1657                                      "      %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1658                                      i,
1659                                      (UV)cache[i * 2],
1660                                      (UV)cache[i * 2 + 1]);
1661             }
1662         }
1663     }
1664 }
1665
1666 /*
1667 =for apidoc magic_dump
1668
1669 Dumps the contents of the MAGIC C<mg> to C<STDERR>.
1670
1671 =cut
1672 */
1673
1674 void
1675 Perl_magic_dump(pTHX_ const MAGIC *mg)
1676 {
1677     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1678 }
1679
1680 void
1681 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1682 {
1683     const char *hvname;
1684
1685     PERL_ARGS_ASSERT_DO_HV_DUMP;
1686
1687     Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1688     if (sv && (hvname = HvNAME_get(sv)))
1689     {
1690         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1691            name which quite legally could contain insane things like tabs, newlines, nulls or
1692            other scary crap - this should produce sane results - except maybe for unicode package
1693            names - but we will wait for someone to file a bug on that - demerphq */
1694         SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1695         PerlIO_printf(file, "\t\"%s\"\n",
1696                               generic_pv_escape( tmpsv, hvname,
1697                                    HvNAMELEN(sv), HvNAMEUTF8(sv)));
1698     }
1699     else
1700         (void)PerlIO_putc(file, '\n');
1701 }
1702
1703 void
1704 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1705 {
1706     PERL_ARGS_ASSERT_DO_GV_DUMP;
1707
1708     Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1709     if (sv) {
1710         SV * const tmpsv = newSVpvs("");
1711         PerlIO_printf(file, "\t\"%s\"\n",
1712                               generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1713     }
1714     else
1715         (void)PerlIO_putc(file, '\n');
1716 }
1717
1718 void
1719 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1720 {
1721     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1722
1723     Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1724     if (sv) {
1725        SV *tmp = newSVpvs_flags("", SVs_TEMP);
1726         const char *hvname;
1727         HV * const stash = GvSTASH(sv);
1728         PerlIO_printf(file, "\t");
1729         /* TODO might have an extra \" here */
1730         if (stash && (hvname = HvNAME_get(stash))) {
1731             PerlIO_printf(file, "\"%s\" :: \"",
1732                                   generic_pv_escape(tmp, hvname,
1733                                       HvNAMELEN(stash), HvNAMEUTF8(stash)));
1734         }
1735         PerlIO_printf(file, "%s\"\n",
1736                               generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1737     }
1738     else
1739         (void)PerlIO_putc(file, '\n');
1740 }
1741
1742 const struct flag_to_name first_sv_flags_names[] = {
1743     {SVs_TEMP, "TEMP,"},
1744     {SVs_OBJECT, "OBJECT,"},
1745     {SVs_GMG, "GMG,"},
1746     {SVs_SMG, "SMG,"},
1747     {SVs_RMG, "RMG,"},
1748     {SVf_IOK, "IOK,"},
1749     {SVf_NOK, "NOK,"},
1750     {SVf_POK, "POK,"}
1751 };
1752
1753 const struct flag_to_name second_sv_flags_names[] = {
1754     {SVf_OOK, "OOK,"},
1755     {SVf_FAKE, "FAKE,"},
1756     {SVf_READONLY, "READONLY,"},
1757     {SVf_PROTECT, "PROTECT,"},
1758     {SVf_BREAK, "BREAK,"},
1759     {SVp_IOK, "pIOK,"},
1760     {SVp_NOK, "pNOK,"},
1761     {SVp_POK, "pPOK,"}
1762 };
1763
1764 const struct flag_to_name cv_flags_names[] = {
1765     {CVf_ANON, "ANON,"},
1766     {CVf_UNIQUE, "UNIQUE,"},
1767     {CVf_CLONE, "CLONE,"},
1768     {CVf_CLONED, "CLONED,"},
1769     {CVf_CONST, "CONST,"},
1770     {CVf_NODEBUG, "NODEBUG,"},
1771     {CVf_LVALUE, "LVALUE,"},
1772     {CVf_NOWARN_AMBIGUOUS, "NOWARN_AMBIGUOUS,"},
1773     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1774     {CVf_CVGV_RC, "CVGV_RC,"},
1775     {CVf_DYNFILE, "DYNFILE,"},
1776     {CVf_AUTOLOAD, "AUTOLOAD,"},
1777     {CVf_HASEVAL, "HASEVAL,"},
1778     {CVf_SLABBED, "SLABBED,"},
1779     {CVf_NAMED, "NAMED,"},
1780     {CVf_LEXICAL, "LEXICAL,"},
1781     {CVf_ISXSUB, "ISXSUB,"},
1782     {CVf_ANONCONST,        "ANONCONST,"},
1783     {CVf_SIGNATURE,        "SIGNATURE,"},
1784     {CVf_REFCOUNTED_ANYSV, "REFCOUNTED_ANYSV,"},
1785     {CVf_IsMETHOD,         "IsMETHOD,"}
1786
1787 };
1788
1789 const struct flag_to_name hv_flags_names[] = {
1790     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1791     {SVphv_LAZYDEL, "LAZYDEL,"},
1792     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1793     {SVf_AMAGIC, "OVERLOAD,"},
1794     {SVphv_CLONEABLE, "CLONEABLE,"}
1795 };
1796
1797 const struct flag_to_name gp_flags_names[] = {
1798     {GVf_INTRO, "INTRO,"},
1799     {GVf_MULTI, "MULTI,"},
1800     {GVf_ASSUMECV, "ASSUMECV,"},
1801 };
1802
1803 const struct flag_to_name gp_flags_imported_names[] = {
1804     {GVf_IMPORTED_SV, " SV"},
1805     {GVf_IMPORTED_AV, " AV"},
1806     {GVf_IMPORTED_HV, " HV"},
1807     {GVf_IMPORTED_CV, " CV"},
1808 };
1809
1810 /* NOTE: this structure is mostly duplicative of one generated by
1811  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1812  * the two. - Yves */
1813 const struct flag_to_name regexp_extflags_names[] = {
1814     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1815     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1816     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1817     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1818     {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1819     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1820     {RXf_PMf_NOCAPTURE,   "PMf_NOCAPURE,"},
1821     {RXf_IS_ANCHORED,     "IS_ANCHORED,"},
1822     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1823     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1824     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1825     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1826     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1827     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1828     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1829     {RXf_SPLIT,           "SPLIT,"},
1830     {RXf_COPY_DONE,       "COPY_DONE,"},
1831     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1832     {RXf_TAINTED,         "TAINTED,"},
1833     {RXf_START_ONLY,      "START_ONLY,"},
1834     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1835     {RXf_WHITE,           "WHITE,"},
1836     {RXf_NULL,            "NULL,"},
1837 };
1838
1839 /* NOTE: this structure is mostly duplicative of one generated by
1840  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1841  * the two. - Yves */
1842 const struct flag_to_name regexp_core_intflags_names[] = {
1843     {PREGf_SKIP,            "SKIP,"},
1844     {PREGf_IMPLICIT,        "IMPLICIT,"},
1845     {PREGf_NAUGHTY,         "NAUGHTY,"},
1846     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1847     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1848     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1849     {PREGf_NOSCAN,          "NOSCAN,"},
1850     {PREGf_GPOS_SEEN,       "GPOS_SEEN,"},
1851     {PREGf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1852     {PREGf_ANCH_MBOL,       "ANCH_MBOL,"},
1853     {PREGf_ANCH_SBOL,       "ANCH_SBOL,"},
1854     {PREGf_ANCH_GPOS,       "ANCH_GPOS,"},
1855 };
1856
1857 /* Minimum number of decimal digits to preserve the significand of NV.  */
1858 #ifdef USE_LONG_DOUBLE
1859 #  ifdef LDBL_DECIMAL_DIG
1860 #    define NV_DECIMAL_DIG      LDBL_DECIMAL_DIG
1861 #  endif
1862 #elif defined(USE_QUADMATH) && defined(I_QUADMATH)
1863 #  ifdef FLT128_DECIMAL_DIG
1864 #    define NV_DECIMAL_DIG      FLT128_DECIMAL_DIG
1865 #  endif
1866 #else  /* NV is double */
1867 #  ifdef DBL_DECIMAL_DIG
1868 #    define NV_DECIMAL_DIG      DBL_DECIMAL_DIG
1869 #  endif
1870 #endif
1871
1872 #ifndef NV_DECIMAL_DIG
1873 #  if defined(NV_MANT_DIG) && FLT_RADIX == 2
1874 /* NV_DECIMAL_DIG = ceil(1 + NV_MANT_DIG * log10(2)), where log10(2) is
1875    approx. 146/485.  This is precise enough up to 2620 bits */
1876 #    define NV_DECIMAL_DIG      (1 + (NV_MANT_DIG * 146 + 484) / 485)
1877 #  endif
1878 #endif
1879
1880 #ifndef NV_DECIMAL_DIG
1881 #  define NV_DECIMAL_DIG        (NV_DIG + 3) /* last resort */
1882 #endif
1883
1884 /* Perl_do_sv_dump():
1885  *
1886  * level:   amount to indent the output
1887  * sv:      the object to dump
1888  * nest:    the current level of recursion
1889  * maxnest: the maximum allowed level of recursion
1890  * dumpops: if true, also dump the ops associated with a CV
1891  * pvlim:   limit on the length of any strings that are output
1892  * */
1893
1894 void
1895 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1896 {
1897     SV *d;
1898     const char *s;
1899     U32 flags;
1900     U32 type;
1901
1902     PERL_ARGS_ASSERT_DO_SV_DUMP;
1903
1904     if (!sv) {
1905         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1906         return;
1907     }
1908
1909     flags = SvFLAGS(sv);
1910     type = SvTYPE(sv);
1911
1912     /* process general SV flags */
1913
1914     d = Perl_newSVpvf(aTHX_
1915                    "(0x%" UVxf ") at 0x%" UVxf "\n%*s  REFCNT = %" IVdf "\n%*s  FLAGS = (",
1916                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1917                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1918                    (int)(PL_dumpindent*level), "");
1919
1920     if ((flags & SVs_PADSTALE))
1921             sv_catpvs(d, "PADSTALE,");
1922     if ((flags & SVs_PADTMP))
1923             sv_catpvs(d, "PADTMP,");
1924     append_flags(d, flags, first_sv_flags_names);
1925     if (flags & SVf_ROK)  {
1926                                 sv_catpvs(d, "ROK,");
1927         if (SvWEAKREF(sv))      sv_catpvs(d, "WEAKREF,");
1928     }
1929     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1930     append_flags(d, flags, second_sv_flags_names);
1931     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1932                            && type != SVt_PVAV) {
1933         if (SvPCS_IMPORTED(sv))
1934                                 sv_catpvs(d, "PCS_IMPORTED,");
1935         else
1936                                 sv_catpvs(d, "SCREAM,");
1937     }
1938
1939     /* process type-specific SV flags */
1940
1941     switch (type) {
1942     case SVt_PVCV:
1943     case SVt_PVFM:
1944         append_flags(d, CvFLAGS(sv), cv_flags_names);
1945         break;
1946     case SVt_PVHV:
1947         append_flags(d, flags, hv_flags_names);
1948         break;
1949     case SVt_PVGV:
1950     case SVt_PVLV:
1951         if (isGV_with_GP(sv)) {
1952             append_flags(d, GvFLAGS(sv), gp_flags_names);
1953         }
1954         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1955             sv_catpvs(d, "IMPORT");
1956             if (GvIMPORTED(sv) == GVf_IMPORTED)
1957                 sv_catpvs(d, "ALL,");
1958             else {
1959                 sv_catpvs(d, "(");
1960                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1961                 sv_catpvs(d, " ),");
1962             }
1963         }
1964         /* FALLTHROUGH */
1965     case SVt_PVMG:
1966     default:
1967         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpvs(d, "IsUV,");
1968         break;
1969
1970     case SVt_PVAV:
1971         break;
1972     }
1973     /* SVphv_SHAREKEYS is also 0x20000000 */
1974     if ((type != SVt_PVHV) && SvUTF8(sv))
1975         sv_catpvs(d, "UTF8");
1976
1977     if (*(SvEND(d) - 1) == ',') {
1978         SvCUR_set(d, SvCUR(d) - 1);
1979         SvPVX(d)[SvCUR(d)] = '\0';
1980     }
1981     sv_catpvs(d, ")");
1982     s = SvPVX_const(d);
1983
1984     /* dump initial SV details */
1985
1986 #ifdef DEBUG_LEAKING_SCALARS
1987     Perl_dump_indent(aTHX_ level, file,
1988         "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1989         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1990         sv->sv_debug_line,
1991         sv->sv_debug_inpad ? "for" : "by",
1992         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1993         PTR2UV(sv->sv_debug_parent),
1994         sv->sv_debug_serial
1995     );
1996 #endif
1997     Perl_dump_indent(aTHX_ level, file, "SV = ");
1998
1999     /* Dump SV type */
2000
2001     if (type < SVt_LAST) {
2002         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
2003
2004         if (type ==  SVt_NULL) {
2005             SvREFCNT_dec_NN(d);
2006             return;
2007         }
2008     } else {
2009         PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
2010         SvREFCNT_dec_NN(d);
2011         return;
2012     }
2013
2014     /* Dump general SV fields */
2015
2016     if ((type >= SVt_PVIV && type <= SVt_PVLV
2017          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
2018         || (type == SVt_IV && !SvROK(sv))) {
2019         if (SvIsUV(sv)
2020                                      )
2021             Perl_dump_indent(aTHX_ level, file, "  UV = %" UVuf, (UV)SvUVX(sv));
2022         else
2023             Perl_dump_indent(aTHX_ level, file, "  IV = %" IVdf, (IV)SvIVX(sv));
2024         (void)PerlIO_putc(file, '\n');
2025     }
2026
2027     if ((type >= SVt_PVNV && type <= SVt_PVLV
2028          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
2029                || type == SVt_NV) {
2030         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2031         STORE_LC_NUMERIC_SET_STANDARD();
2032         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DECIMAL_DIG, SvNVX(sv));
2033         RESTORE_LC_NUMERIC();
2034     }
2035
2036     if (SvROK(sv)) {
2037         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%" UVxf "\n",
2038                                PTR2UV(SvRV(sv)));
2039         if (nest < maxnest)
2040             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
2041     }
2042
2043     if (type < SVt_PV) {
2044         SvREFCNT_dec_NN(d);
2045         return;
2046     }
2047
2048     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
2049      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
2050         const bool re = isREGEXP(sv);
2051         const char * const ptr =
2052             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2053         if (ptr) {
2054             STRLEN delta;
2055             if (SvOOK(sv)) {
2056                 SvOOK_offset(sv, delta);
2057                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %" UVuf "\n",
2058                                  (UV) delta);
2059             } else {
2060                 delta = 0;
2061             }
2062             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%" UVxf " ",
2063                                    PTR2UV(ptr));
2064             if (SvOOK(sv)) {
2065                 PerlIO_printf(file, "( %s . ) ",
2066                               _pv_display_for_dump(d, ptr - delta, delta, 0,
2067                                          pvlim));
2068             }
2069             if (type == SVt_INVLIST) {
2070                 PerlIO_printf(file, "\n");
2071                 /* 4 blanks indents 2 beyond the PV, etc */
2072                 _invlist_dump(file, level, "    ", sv);
2073             }
2074             else {
2075                 PerlIO_printf(file, "%s", _pv_display_for_dump(d, ptr, SvCUR(sv),
2076                                                      re ? 0 : SvLEN(sv),
2077                                                      pvlim));
2078                 if (SvUTF8(sv)) /* the 6?  \x{....} */
2079                     PerlIO_printf(file, " [UTF8 \"%s\"]",
2080                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
2081                                                         UNI_DISPLAY_QQ));
2082                 if (SvIsBOOL(sv))
2083                     PerlIO_printf(file, " [BOOL %s]", ptr == PL_Yes ? "PL_Yes" : "PL_No");
2084                 PerlIO_printf(file, "\n");
2085             }
2086             Perl_dump_indent(aTHX_ level, file, "  CUR = %" IVdf "\n", (IV)SvCUR(sv));
2087             if (re && type == SVt_PVLV)
2088                 /* LV-as-REGEXP usurps len field to store pointer to
2089                  * regexp struct */
2090                 Perl_dump_indent(aTHX_ level, file, "  REGEXP = 0x%" UVxf "\n",
2091                    PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
2092             else
2093                 Perl_dump_indent(aTHX_ level, file, "  LEN = %" IVdf "\n",
2094                                        (IV)SvLEN(sv));
2095 #ifdef PERL_COPY_ON_WRITE
2096             if (SvIsCOW(sv) && SvLEN(sv))
2097                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
2098                                        CowREFCNT(sv));
2099 #endif
2100         }
2101         else
2102             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
2103     }
2104
2105     if (type >= SVt_PVMG) {
2106         if (SvMAGIC(sv))
2107                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
2108         if (SvSTASH(sv))
2109             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
2110
2111         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
2112             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %" IVdf "\n",
2113                                    (IV)BmUSEFUL(sv));
2114         }
2115     }
2116
2117     /* Dump type-specific SV fields */
2118
2119     switch (type) {
2120     case SVt_PVAV:
2121         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf,
2122                                PTR2UV(AvARRAY(sv)));
2123         if (AvARRAY(sv) != AvALLOC(sv)) {
2124             PerlIO_printf(file, " (offset=%" IVdf ")\n",
2125                                 (IV)(AvARRAY(sv) - AvALLOC(sv)));
2126             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%" UVxf "\n",
2127                                    PTR2UV(AvALLOC(sv)));
2128         }
2129         else
2130             (void)PerlIO_putc(file, '\n');
2131         Perl_dump_indent(aTHX_ level, file, "  FILL = %" IVdf "\n",
2132                                (IV)AvFILLp(sv));
2133         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
2134                                (IV)AvMAX(sv));
2135         SvPVCLEAR(d);
2136         if (AvREAL(sv)) sv_catpvs(d, ",REAL");
2137         if (AvREIFY(sv))        sv_catpvs(d, ",REIFY");
2138         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
2139                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
2140         if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
2141             SSize_t count;
2142             SV **svp = AvARRAY(MUTABLE_AV(sv));
2143             for (count = 0;
2144                  count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
2145                  count++, svp++)
2146             {
2147                 SV* const elt = *svp;
2148                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
2149                                        (IV)count);
2150                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2151             }
2152         }
2153         break;
2154     case SVt_PVHV: {
2155         U32 totalkeys;
2156         if (HvHasAUX(sv)) {
2157             struct xpvhv_aux *const aux = HvAUX(sv);
2158             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %" UVuf "\n",
2159                              (UV)aux->xhv_aux_flags);
2160         }
2161         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
2162         totalkeys = HvTOTALKEYS(MUTABLE_HV(sv));
2163         if (totalkeys) {
2164             /* Show distribution of HEs in the ARRAY */
2165             int freq[200];
2166 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
2167             int i;
2168             int max = 0;
2169             U32 pow2 = 2;
2170             U32 keys = totalkeys;
2171             NV theoret, sum = 0;
2172
2173             PerlIO_printf(file, "  (");
2174             Zero(freq, FREQ_MAX + 1, int);
2175             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
2176                 HE* h;
2177                 int count = 0;
2178                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
2179                     count++;
2180                 if (count > FREQ_MAX)
2181                     count = FREQ_MAX;
2182                 freq[count]++;
2183                 if (max < count)
2184                     max = count;
2185             }
2186             for (i = 0; i <= max; i++) {
2187                 if (freq[i]) {
2188                     PerlIO_printf(file, "%d%s:%d", i,
2189                                   (i == FREQ_MAX) ? "+" : "",
2190                                   freq[i]);
2191                     if (i != max)
2192                         PerlIO_printf(file, ", ");
2193                 }
2194             }
2195             (void)PerlIO_putc(file, ')');
2196             /* The "quality" of a hash is defined as the total number of
2197                comparisons needed to access every element once, relative
2198                to the expected number needed for a random hash.
2199
2200                The total number of comparisons is equal to the sum of
2201                the squares of the number of entries in each bucket.
2202                For a random hash of n keys into k buckets, the expected
2203                value is
2204                                 n + n(n-1)/2k
2205             */
2206
2207             for (i = max; i > 0; i--) { /* Precision: count down. */
2208                 sum += freq[i] * i * i;
2209             }
2210             while ((keys = keys >> 1))
2211                 pow2 = pow2 << 1;
2212             theoret = totalkeys;
2213             theoret += theoret * (theoret-1)/pow2;
2214             (void)PerlIO_putc(file, '\n');
2215             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"
2216                                    NVff "%%", theoret/sum*100);
2217         }
2218         (void)PerlIO_putc(file, '\n');
2219         Perl_dump_indent(aTHX_ level, file, "  KEYS = %" IVdf "\n",
2220                                (IV)totalkeys);
2221         {
2222             STRLEN count = 0;
2223             HE **ents = HvARRAY(sv);
2224
2225             if (ents) {
2226                 HE *const *const last = ents + HvMAX(sv);
2227                 count = last + 1 - ents;
2228
2229                 do {
2230                     if (!*ents)
2231                         --count;
2232                 } while (++ents <= last);
2233             }
2234
2235             Perl_dump_indent(aTHX_ level, file, "  FILL = %" UVuf "\n",
2236                              (UV)count);
2237         }
2238         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
2239                                (IV)HvMAX(sv));
2240         if (HvHasAUX(sv)) {
2241             Perl_dump_indent(aTHX_ level, file, "  RITER = %" IVdf "\n",
2242                                    (IV)HvRITER_get(sv));
2243             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%" UVxf "\n",
2244                                    PTR2UV(HvEITER_get(sv)));
2245 #ifdef PERL_HASH_RANDOMIZE_KEYS
2246             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%" UVxf,
2247                                    (UV)HvRAND_get(sv));
2248             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2249                 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2250                                     (UV)HvLASTRAND_get(sv));
2251             }
2252 #endif
2253             (void)PerlIO_putc(file, '\n');
2254         }
2255         {
2256             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2257             if (mg && mg->mg_obj) {
2258                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2259             }
2260         }
2261         {
2262             const char * const hvname = HvNAME_get(sv);
2263             if (hvname) {
2264                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2265                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2266                                        generic_pv_escape( tmpsv, hvname,
2267                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
2268         }
2269         }
2270         if (HvHasAUX(sv)) {
2271             AV * const backrefs
2272                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2273             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2274             if (HvAUX(sv)->xhv_name_count)
2275                 Perl_dump_indent(aTHX_
2276                  level, file, "  NAMECOUNT = %" IVdf "\n",
2277                  (IV)HvAUX(sv)->xhv_name_count
2278                 );
2279             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2280                 const I32 count = HvAUX(sv)->xhv_name_count;
2281                 if (count) {
2282                     SV * const names = newSVpvs_flags("", SVs_TEMP);
2283                     /* The starting point is the first element if count is
2284                        positive and the second element if count is negative. */
2285                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2286                         + (count < 0 ? 1 : 0);
2287                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2288                         + (count < 0 ? -count : count);
2289                     while (hekp < endp) {
2290                         if (*hekp) {
2291                             SV *tmp = newSVpvs_flags("", SVs_TEMP);
2292                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2293                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2294                         } else {
2295                             /* This should never happen. */
2296                             sv_catpvs(names, ", (null)");
2297                         }
2298                         ++hekp;
2299                     }
2300                     Perl_dump_indent(aTHX_
2301                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
2302                     );
2303                 }
2304                 else {
2305                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2306                     const char *const hvename = HvENAME_get(sv);
2307                     Perl_dump_indent(aTHX_
2308                      level, file, "  ENAME = \"%s\"\n",
2309                      generic_pv_escape(tmp, hvename,
2310                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2311                 }
2312             }
2313             if (backrefs) {
2314                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%" UVxf "\n",
2315                                  PTR2UV(backrefs));
2316                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2317                            dumpops, pvlim);
2318             }
2319             if (meta) {
2320                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2321                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"
2322                                  UVxf ")\n",
2323                                  generic_pv_escape( tmpsv, meta->mro_which->name,
2324                                 meta->mro_which->length,
2325                                 (meta->mro_which->kflags & HVhek_UTF8)),
2326                                  PTR2UV(meta->mro_which));
2327                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"
2328                                  UVxf "\n",
2329                                  (UV)meta->cache_gen);
2330                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%" UVxf "\n",
2331                                  (UV)meta->pkg_gen);
2332                 if (meta->mro_linear_all) {
2333                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"
2334                                  UVxf "\n",
2335                                  PTR2UV(meta->mro_linear_all));
2336                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2337                            dumpops, pvlim);
2338                 }
2339                 if (meta->mro_linear_current) {
2340                     Perl_dump_indent(aTHX_ level, file,
2341                                  "  MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2342                                  PTR2UV(meta->mro_linear_current));
2343                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2344                            dumpops, pvlim);
2345                 }
2346                 if (meta->mro_nextmethod) {
2347                     Perl_dump_indent(aTHX_ level, file,
2348                                  "  MRO_NEXTMETHOD = 0x%" UVxf "\n",
2349                                  PTR2UV(meta->mro_nextmethod));
2350                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2351                            dumpops, pvlim);
2352                 }
2353                 if (meta->isa) {
2354                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%" UVxf "\n",
2355                                  PTR2UV(meta->isa));
2356                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2357                            dumpops, pvlim);
2358                 }
2359             }
2360         }
2361         if (nest < maxnest) {
2362             HV * const hv = MUTABLE_HV(sv);
2363
2364             if (HvTOTALKEYS(hv)) {
2365                 STRLEN i;
2366                 int count = maxnest - nest;
2367                 for (i=0; i <= HvMAX(hv); i++) {
2368                     HE *he;
2369                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2370                         U32 hash;
2371                         SV * keysv;
2372                         const char * keypv;
2373                         SV * elt;
2374                         STRLEN len;
2375
2376                         if (count-- <= 0) goto DONEHV;
2377
2378                         hash = HeHASH(he);
2379                         keysv = hv_iterkeysv(he);
2380                         keypv = SvPV_const(keysv, len);
2381                         elt = HeVAL(he);
2382
2383                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", _pv_display_for_dump(d, keypv, len, 0, pvlim));
2384                         if (SvUTF8(keysv))
2385                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2386                         if (HvEITER_get(hv) == he)
2387                             PerlIO_printf(file, "[CURRENT] ");
2388                         PerlIO_printf(file, "HASH = 0x%" UVxf, (UV) hash);
2389
2390                         if (sv == (SV*)PL_strtab)
2391                             PerlIO_printf(file, " REFCNT = 0x%" UVxf "\n",
2392                                 (UV)he->he_valu.hent_refcount );
2393                         else {
2394                             (void)PerlIO_putc(file, '\n');
2395                             do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2396                         }
2397                     }
2398                 }
2399               DONEHV:;
2400             }
2401         }
2402         break;
2403     } /* case SVt_PVHV */
2404
2405     case SVt_PVCV:
2406         if (CvAUTOLOAD(sv)) {
2407             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2408             STRLEN len;
2409             const char *const name =  SvPV_const(sv, len);
2410             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
2411                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2412         }
2413         if (SvPOK(sv)) {
2414             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2415             const char *const proto = CvPROTO(sv);
2416             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
2417                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2418                                 SvUTF8(sv)));
2419         }
2420         /* FALLTHROUGH */
2421     case SVt_PVFM:
2422         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
2423         if (!CvISXSUB(sv)) {
2424             if (CvSTART(sv)) {
2425                 if (CvSLABBED(sv))
2426                     Perl_dump_indent(aTHX_ level, file,
2427                                  "  SLAB = 0x%" UVxf "\n",
2428                                  PTR2UV(CvSTART(sv)));
2429                 else
2430                     Perl_dump_indent(aTHX_ level, file,
2431                                  "  START = 0x%" UVxf " ===> %" IVdf "\n",
2432                                  PTR2UV(CvSTART(sv)),
2433                                  (IV)sequence_num(CvSTART(sv)));
2434             }
2435             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%" UVxf "\n",
2436                              PTR2UV(CvROOT(sv)));
2437             if (CvROOT(sv) && dumpops) {
2438                 do_op_dump(level+1, file, CvROOT(sv));
2439             }
2440         } else {
2441             SV * const constant = cv_const_sv((const CV *)sv);
2442
2443             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2444
2445             if (constant) {
2446                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%" UVxf
2447                                  " (CONST SV)\n",
2448                                  PTR2UV(CvXSUBANY(sv).any_ptr));
2449                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2450                            pvlim);
2451             } else {
2452                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %" IVdf "\n",
2453                                  (IV)CvXSUBANY(sv).any_i32);
2454             }
2455         }
2456         if (CvNAMED(sv))
2457             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2458                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
2459         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
2460         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
2461         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"
2462                                       IVdf "\n", (IV)CvDEPTH(sv));
2463         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n",
2464                                (UV)CvFLAGS(sv));
2465         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2466         if (!CvISXSUB(sv)) {
2467             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2468             if (nest < maxnest) {
2469                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2470             }
2471         }
2472         else
2473             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
2474         {
2475             const CV * const outside = CvOUTSIDE(sv);
2476             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%" UVxf " (%s)\n",
2477                         PTR2UV(outside),
2478                         (!outside ? "null"
2479                          : CvANON(outside) ? "ANON"
2480                          : (outside == PL_main_cv) ? "MAIN"
2481                          : CvUNIQUE(outside) ? "UNIQUE"
2482                          : CvGV(outside) ?
2483                              generic_pv_escape(
2484                                  newSVpvs_flags("", SVs_TEMP),
2485                                  GvNAME(CvGV(outside)),
2486                                  GvNAMELEN(CvGV(outside)),
2487                                  GvNAMEUTF8(CvGV(outside)))
2488                          : "UNDEFINED"));
2489         }
2490         if (CvOUTSIDE(sv)
2491          && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2492             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2493         break;
2494
2495     case SVt_PVGV:
2496     case SVt_PVLV:
2497         if (type == SVt_PVLV) {
2498             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2499             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2500             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2501             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2502             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2503             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2504                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2505                     dumpops, pvlim);
2506         }
2507         if (isREGEXP(sv)) goto dumpregexp;
2508         if (!isGV_with_GP(sv))
2509             break;
2510         {
2511             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2512             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2513                      generic_pv_escape(tmpsv, GvNAME(sv),
2514                                        GvNAMELEN(sv),
2515                                        GvNAMEUTF8(sv)));
2516         }
2517         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2518         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2519         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2520         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2521         if (!GvGP(sv))
2522             break;
2523         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2524         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2525         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2526         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%" UVxf "  \n", PTR2UV(GvFORM(sv)));
2527         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2528         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2529         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2530         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2531         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%" UVxf
2532                                             " (%s)\n",
2533                                (UV)GvGPFLAGS(sv),
2534                                "");
2535         Perl_dump_indent(aTHX_ level, file, "    LINE = %" LINE_Tf "\n", (line_t)GvLINE(sv));
2536         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2537         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2538         break;
2539     case SVt_PVIO:
2540         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2541         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2542         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2543         Perl_dump_indent(aTHX_ level, file, "  LINES = %" IVdf "\n", (IV)IoLINES(sv));
2544         Perl_dump_indent(aTHX_ level, file, "  PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2545         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2546         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2547         if (IoTOP_NAME(sv))
2548             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2549         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2550             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2551         else {
2552             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%" UVxf "\n",
2553                              PTR2UV(IoTOP_GV(sv)));
2554             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2555                         maxnest, dumpops, pvlim);
2556         }
2557         /* Source filters hide things that are not GVs in these three, so let's
2558            be careful out there.  */
2559         if (IoFMT_NAME(sv))
2560             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2561         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2562             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2563         else {
2564             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%" UVxf "\n",
2565                              PTR2UV(IoFMT_GV(sv)));
2566             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2567                         maxnest, dumpops, pvlim);
2568         }
2569         if (IoBOTTOM_NAME(sv))
2570             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2571         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2572             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2573         else {
2574             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%" UVxf "\n",
2575                              PTR2UV(IoBOTTOM_GV(sv)));
2576             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2577                         maxnest, dumpops, pvlim);
2578         }
2579         if (isPRINT(IoTYPE(sv)))
2580             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2581         else
2582             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2583         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2584         break;
2585     case SVt_REGEXP:
2586       dumpregexp:
2587         {
2588             struct regexp * const r = ReANY((REGEXP*)sv);
2589
2590 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2591             sv_setpv(d,"");                                 \
2592             append_flags(d, flags, names);     \
2593             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2594                 SvCUR_set(d, SvCUR(d) - 1);                 \
2595                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2596             }                                               \
2597 } STMT_END
2598             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2599             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%" UVxf " (%s)\n",
2600                                 (UV)(r->compflags), SvPVX_const(d));
2601
2602             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2603             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%" UVxf " (%s)\n",
2604                                 (UV)(r->extflags), SvPVX_const(d));
2605
2606             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%" UVxf " (%s)\n",
2607                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2608             if (r->engine == &PL_core_reg_engine) {
2609                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2610                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf " (%s)\n",
2611                                 (UV)(r->intflags), SvPVX_const(d));
2612             } else {
2613                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf "(Plug in)\n",
2614                                 (UV)(r->intflags));
2615             }
2616 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2617             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %" UVuf "\n",
2618                                 (UV)(r->nparens));
2619             Perl_dump_indent(aTHX_ level, file, "  LOGICAL_NPARENS = %" UVuf "\n",
2620                                 (UV)(r->logical_nparens));
2621
2622 #define SV_SET_STRINGIFY_I32_PAREN_ARRAY(d,count,ary)     \
2623     STMT_START {                                    \
2624         U32 n;                                      \
2625         sv_setpv(d,"{ ");                           \
2626         /* 0 element is irrelevant */               \
2627         for(n=0; n <= count; n++)                   \
2628             sv_catpvf(d,"%" IVdf "%s",              \
2629                 (IV)ary[n],                         \
2630                 n == count ? "" : ", ");            \
2631         sv_catpvs(d," }\n");                        \
2632     } STMT_END
2633
2634             Perl_dump_indent(aTHX_ level, file, "  LOGICAL_TO_PARNO = 0x%" UVxf "\n",
2635                                 PTR2UV(r->logical_to_parno));
2636             if (r->logical_to_parno) {
2637                 SV_SET_STRINGIFY_I32_PAREN_ARRAY(d, r->logical_nparens, r->logical_to_parno);
2638                 Perl_dump_indent(aTHX_ level, file, "    %" SVf, d);
2639             }
2640             Perl_dump_indent(aTHX_ level, file, "  PARNO_TO_LOGICAL = 0x%" UVxf "\n",
2641                                 PTR2UV(r->parno_to_logical));
2642             if (r->parno_to_logical) {
2643                 SV_SET_STRINGIFY_I32_PAREN_ARRAY(d, r->nparens, r->parno_to_logical);
2644                 Perl_dump_indent(aTHX_ level, file, "    %" SVf, d);
2645             }
2646
2647             Perl_dump_indent(aTHX_ level, file, "  PARNO_TO_LOGICAL_NEXT = 0x%" UVxf "\n",
2648                                 PTR2UV(r->parno_to_logical_next));
2649             if (r->parno_to_logical_next) {
2650                 SV_SET_STRINGIFY_I32_PAREN_ARRAY(d, r->nparens, r->parno_to_logical_next);
2651                 Perl_dump_indent(aTHX_ level, file, "    %" SVf, d);
2652             }
2653 #undef SV_SET_STRINGIFY_I32_ARRAY
2654
2655             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %" UVuf "\n",
2656                                 (UV)(RXp_LASTPAREN(r)));
2657             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %" UVuf "\n",
2658                                 (UV)(RXp_LASTCLOSEPAREN(r)));
2659             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %" IVdf "\n",
2660                                 (IV)(RXp_MINLEN(r)));
2661             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %" IVdf "\n",
2662                                 (IV)(RXp_MINLENRET(r)));
2663             Perl_dump_indent(aTHX_ level, file, "  GOFS = %" UVuf "\n",
2664                                 (UV)(RXp_GOFS(r)));
2665             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %" UVuf "\n",
2666                                 (UV)(RXp_PRE_PREFIX(r)));
2667             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %" IVdf "\n",
2668                                 (IV)(RXp_SUBLEN(r)));
2669             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %" IVdf "\n",
2670                                 (IV)(RXp_SUBOFFSET(r)));
2671             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %" IVdf "\n",
2672                                 (IV)(RXp_SUBCOFFSET(r)));
2673             if (RXp_SUBBEG(r))
2674                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%" UVxf " %s\n",
2675                             PTR2UV(RXp_SUBBEG(r)),
2676                             pv_display(d, RXp_SUBBEG(r), RXp_SUBLEN(r), 50, pvlim));
2677             else
2678                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2679             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%" UVxf "\n",
2680                                 PTR2UV(RXp_PAREN_NAMES(r)));
2681             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%" UVxf "\n",
2682                                 PTR2UV(RXp_SUBSTRS(r)));
2683             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%" UVxf "\n",
2684                                 PTR2UV(RXp_PPRIVATE(r)));
2685             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%" UVxf "\n",
2686                                 PTR2UV(RXp_OFFSp(r)));
2687             if (RXp_OFFSp(r)) {
2688                 U32 n;
2689                 sv_setpvs(d,"[ ");
2690                 /* note offs[0] is for the whole match, and
2691                  * the data for $1 is in offs[1]. Thus we have to
2692                  * show one more than we have nparens. */
2693                 for(n = 0; n <= r->nparens; n++) {
2694                     sv_catpvf(d,"%" IVdf ":%" IVdf "%s",
2695                         (IV)RXp_OFFSp(r)[n].start, (IV)RXp_OFFSp(r)[n].end,
2696                         n+1 > r->nparens ? " ]\n" : ", ");
2697                 }
2698                 Perl_dump_indent(aTHX_ level, file, "    %" SVf, d);
2699             }
2700             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%" UVxf "\n",
2701                                 PTR2UV(RXp_QR_ANONCV(r)));
2702 #ifdef PERL_ANY_COW
2703             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%" UVxf "\n",
2704                                 PTR2UV(RXp_SAVED_COPY(r)));
2705 #endif
2706             /* this should go LAST or the output gets really confusing */
2707             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%" UVxf "\n",
2708                                 PTR2UV(RXp_MOTHER_RE(r)));
2709             if (nest < maxnest && RXp_MOTHER_RE(r))
2710                 do_sv_dump(level+1, file, (SV *)RXp_MOTHER_RE(r), nest+1,
2711                            maxnest, dumpops, pvlim);
2712         }
2713         break;
2714     case SVt_PVOBJ:
2715         Perl_dump_indent(aTHX_ level, file, "  MAXFIELD = %" IVdf "\n",
2716                 (IV)ObjectMAXFIELD(sv));
2717         Perl_dump_indent(aTHX_ level, file, "  FIELDS = 0x%" UVxf "\n",
2718                 PTR2UV(ObjectFIELDS(sv)));
2719         if (nest < maxnest && ObjectFIELDS(sv)) {
2720             SSize_t count;
2721             SV **svp = ObjectFIELDS(sv);
2722             PADNAME **pname = PadnamelistARRAY(HvAUX(SvSTASH(sv))->xhv_class_fields);
2723             for (count = 0;
2724                  count <= ObjectMAXFIELD(sv) && count < maxnest;
2725                  count++, svp++)
2726             {
2727                 SV *const field = *svp;
2728                 PADNAME *pn = pname[count];
2729
2730                 Perl_dump_indent(aTHX_ level + 1, file, "Field No. %" IVdf " (%s)\n",
2731                         (IV)count, PadnamePV(pn));
2732
2733                 do_sv_dump(level+1, file, field, nest+1, maxnest, dumpops, pvlim);
2734             }
2735         }
2736         break;
2737     }
2738     SvREFCNT_dec_NN(d);
2739 }
2740
2741 /*
2742 =for apidoc sv_dump
2743
2744 Dumps the contents of an SV to the C<STDERR> filehandle.
2745
2746 For an example of its output, see L<Devel::Peek>. If
2747 the item is an SvROK it will dump items to a depth of 4,
2748 otherwise it will dump only the top level item, which
2749 means that it will not dump the contents of an AV * or
2750 HV *. For that use C<av_dump()> or C<hv_dump()>.
2751
2752 =for apidoc sv_dump_depth
2753
2754 Dumps the contents of an SV to the C<STDERR> filehandle
2755 to the depth requested. This function can be used on any
2756 SV derived type (GV, HV, AV) with an appropriate cast.
2757 This is a more flexible variant of sv_dump(). For example
2758
2759     HV *hv = ...;
2760     sv_dump_depth((SV*)hv, 2);
2761
2762 would dump the hv, its keys and values, but would not recurse
2763 into any RV values.
2764
2765 =for apidoc av_dump
2766
2767 Dumps the contents of an AV to the C<STDERR> filehandle,
2768 Similar to using Devel::Peek on an arrayref but does not
2769 expect an RV wrapper. Dumps contents to a depth of 3 levels
2770 deep.
2771
2772 =for apidoc hv_dump
2773
2774 Dumps the contents of an HV to the C<STDERR> filehandle.
2775 Similar to using Devel::Peek on an hashref but does not
2776 expect an RV wrapper. Dumps contents to a depth of 3 levels
2777 deep.
2778
2779 =cut
2780 */
2781
2782 void
2783 Perl_sv_dump(pTHX_ SV *sv)
2784 {
2785     if (sv && SvROK(sv))
2786         sv_dump_depth(sv, 4);
2787     else
2788         sv_dump_depth(sv, 0);
2789 }
2790
2791 void
2792 Perl_sv_dump_depth(pTHX_ SV *sv, I32 depth)
2793 {
2794     do_sv_dump(0, Perl_debug_log, sv, 0, depth, 0, 0);
2795 }
2796
2797 void
2798 Perl_av_dump(pTHX_ AV *av)
2799 {
2800     sv_dump_depth((SV*)av, 3);
2801 }
2802
2803 void
2804 Perl_hv_dump(pTHX_ HV *hv)
2805 {
2806     sv_dump_depth((SV*)hv, 3);
2807 }
2808
2809 int
2810 Perl_runops_debug(pTHX)
2811 {
2812 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2813     SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2814
2815     PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2816 #endif
2817
2818     if (!PL_op) {
2819         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2820         return 0;
2821     }
2822     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2823     do {
2824 #ifdef PERL_TRACE_OPS
2825         ++PL_op_exec_cnt[PL_op->op_type];
2826 #endif
2827 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2828         if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2829             Perl_croak_nocontext(
2830                 "panic: previous op failed to extend arg stack: "
2831                 "base=%p, sp=%p, hwm=%p\n",
2832                     PL_stack_base, PL_stack_sp,
2833                     PL_stack_base + PL_curstackinfo->si_stack_hwm);
2834         PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2835 #endif
2836         if (PL_debug) {
2837             ENTER;
2838             SAVETMPS;
2839             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2840                 PerlIO_printf(Perl_debug_log,
2841                               "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2842                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2843                               PTR2UV(*PL_watchaddr));
2844             if (DEBUG_s_TEST_) {
2845                 if (DEBUG_v_TEST_) {
2846                     PerlIO_printf(Perl_debug_log, "\n");
2847                     deb_stack_all();
2848                 }
2849                 else
2850                     debstack();
2851             }
2852
2853
2854             if (DEBUG_t_TEST_) debop(PL_op);
2855             if (DEBUG_P_TEST_) debprof(PL_op);
2856             FREETMPS;
2857             LEAVE;
2858         }
2859
2860         PERL_DTRACE_PROBE_OP(PL_op);
2861     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2862     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2863     PERL_ASYNC_CHECK();
2864
2865 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2866     if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2867         PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2868 #endif
2869     TAINT_NOT;
2870     return 0;
2871 }
2872
2873
2874 /* print the names of the n lexical vars starting at pad offset off */
2875
2876 STATIC void
2877 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2878 {
2879     PADNAME *sv;
2880     CV * const cv = deb_curcv(cxstack_ix);
2881     PADNAMELIST *comppad = NULL;
2882     int i;
2883
2884     if (cv) {
2885         PADLIST * const padlist = CvPADLIST(cv);
2886         comppad = PadlistNAMES(padlist);
2887     }
2888     if (paren)
2889         PerlIO_printf(Perl_debug_log, "(");
2890     for (i = 0; i < n; i++) {
2891         if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2892             PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2893         else
2894             PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2895                     (UV)(off+i));
2896         if (i < n - 1)
2897             PerlIO_printf(Perl_debug_log, ",");
2898     }
2899     if (paren)
2900         PerlIO_printf(Perl_debug_log, ")");
2901 }
2902
2903
2904 /* append to the out SV, the name of the lexical at offset off in the CV
2905  * cv */
2906
2907 static void
2908 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2909         bool paren, bool is_scalar)
2910 {
2911     PADNAME *sv;
2912     PADNAMELIST *namepad = NULL;
2913     int i;
2914
2915     if (cv) {
2916         PADLIST * const padlist = CvPADLIST(cv);
2917         namepad = PadlistNAMES(padlist);
2918     }
2919
2920     if (paren)
2921         sv_catpvs_nomg(out, "(");
2922     for (i = 0; i < n; i++) {
2923         if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2924         {
2925             STRLEN cur = SvCUR(out);
2926             Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2927                                  UTF8fARG(1, PadnameLEN(sv) - 1,
2928                                           PadnamePV(sv) + 1));
2929             if (is_scalar)
2930                 SvPVX(out)[cur] = '$';
2931         }
2932         else
2933             Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2934         if (i < n - 1)
2935             sv_catpvs_nomg(out, ",");
2936     }
2937     if (paren)
2938         sv_catpvs_nomg(out, "(");
2939 }
2940
2941
2942 static void
2943 S_append_gv_name(pTHX_ GV *gv, SV *out)
2944 {
2945     SV *sv;
2946     if (!gv) {
2947         sv_catpvs_nomg(out, "<NULLGV>");
2948         return;
2949     }
2950     sv = newSV_type(SVt_NULL);
2951     gv_fullname4(sv, gv, NULL, FALSE);
2952     Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2953     SvREFCNT_dec_NN(sv);
2954 }
2955
2956 #ifdef USE_ITHREADS
2957 #  define ITEM_SV(item) (comppad ? \
2958     *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2959 #else
2960 #  define ITEM_SV(item) UNOP_AUX_item_sv(item)
2961 #endif
2962
2963
2964 /* return a temporary SV containing a stringified representation of
2965  * the op_aux field of a MULTIDEREF op, associated with CV cv
2966  */
2967
2968 SV*
2969 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2970 {
2971     UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2972     UV actions = items->uv;
2973     SV *sv;
2974     bool last = 0;
2975     bool is_hash = FALSE;
2976     int derefs = 0;
2977     SV *out = newSVpvn_flags("",0,SVs_TEMP);
2978 #ifdef USE_ITHREADS
2979     PAD *comppad;
2980
2981     if (cv) {
2982         PADLIST *padlist = CvPADLIST(cv);
2983         comppad = PadlistARRAY(padlist)[1];
2984     }
2985     else
2986         comppad = NULL;
2987 #endif
2988
2989     PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2990
2991     while (!last) {
2992         switch (actions & MDEREF_ACTION_MASK) {
2993
2994         case MDEREF_reload:
2995             actions = (++items)->uv;
2996             continue;
2997             NOT_REACHED; /* NOTREACHED */
2998
2999         case MDEREF_HV_padhv_helem:
3000             is_hash = TRUE;
3001             /* FALLTHROUGH */
3002         case MDEREF_AV_padav_aelem:
3003             derefs = 1;
3004             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
3005             goto do_elem;
3006             NOT_REACHED; /* NOTREACHED */
3007
3008         case MDEREF_HV_gvhv_helem:
3009             is_hash = TRUE;
3010             /* FALLTHROUGH */
3011         case MDEREF_AV_gvav_aelem:
3012             derefs = 1;
3013             items++;
3014             sv = ITEM_SV(items);
3015             S_append_gv_name(aTHX_ (GV*)sv, out);
3016             goto do_elem;
3017             NOT_REACHED; /* NOTREACHED */
3018
3019         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
3020             is_hash = TRUE;
3021             /* FALLTHROUGH */
3022         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
3023             items++;
3024             sv = ITEM_SV(items);
3025             S_append_gv_name(aTHX_ (GV*)sv, out);
3026             goto do_vivify_rv2xv_elem;
3027             NOT_REACHED; /* NOTREACHED */
3028
3029         case MDEREF_HV_padsv_vivify_rv2hv_helem:
3030             is_hash = TRUE;
3031             /* FALLTHROUGH */
3032         case MDEREF_AV_padsv_vivify_rv2av_aelem:
3033             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
3034             goto do_vivify_rv2xv_elem;
3035             NOT_REACHED; /* NOTREACHED */
3036
3037         case MDEREF_HV_pop_rv2hv_helem:
3038         case MDEREF_HV_vivify_rv2hv_helem:
3039             is_hash = TRUE;
3040             /* FALLTHROUGH */
3041         do_vivify_rv2xv_elem:
3042         case MDEREF_AV_pop_rv2av_aelem:
3043         case MDEREF_AV_vivify_rv2av_aelem:
3044             if (!derefs++)
3045                 sv_catpvs_nomg(out, "->");
3046         do_elem:
3047             if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
3048                 sv_catpvs_nomg(out, "->");
3049                 last = 1;
3050                 break;
3051             }
3052
3053             sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
3054             switch (actions & MDEREF_INDEX_MASK) {
3055             case MDEREF_INDEX_const:
3056                 if (is_hash) {
3057                     items++;
3058                     sv = ITEM_SV(items);
3059                     if (!sv)
3060                         sv_catpvs_nomg(out, "???");
3061                     else {
3062                         STRLEN cur;
3063                         char *s;
3064                         s = SvPV(sv, cur);
3065                         pv_pretty(out, s, cur, 30,
3066                                     NULL, NULL,
3067                                     (PERL_PV_PRETTY_NOCLEAR
3068                                     |PERL_PV_PRETTY_QUOTE
3069                                     |PERL_PV_PRETTY_ELLIPSES));
3070                     }
3071                 }
3072                 else
3073                     Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
3074                 break;
3075             case MDEREF_INDEX_padsv:
3076                 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
3077                 break;
3078             case MDEREF_INDEX_gvsv:
3079                 items++;
3080                 sv = ITEM_SV(items);
3081                 S_append_gv_name(aTHX_ (GV*)sv, out);
3082                 break;
3083             }
3084             sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
3085
3086             if (actions & MDEREF_FLAG_last)
3087                 last = 1;
3088             is_hash = FALSE;
3089
3090             break;
3091
3092         default:
3093             PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
3094                 (int)(actions & MDEREF_ACTION_MASK));
3095             last = 1;
3096             break;
3097
3098         } /* switch */
3099
3100         actions >>= MDEREF_SHIFT;
3101     } /* while */
3102     return out;
3103 }
3104
3105
3106 /* Return a temporary SV containing a stringified representation of
3107  * the op_aux field of a MULTICONCAT op. Note that if the aux contains
3108  * both plain and utf8 versions of the const string and indices, only
3109  * the first is displayed.
3110  */
3111
3112 SV*
3113 Perl_multiconcat_stringify(pTHX_ const OP *o)
3114 {
3115     UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
3116     UNOP_AUX_item *lens;
3117     STRLEN len;
3118     SSize_t nargs;
3119     char *s;
3120     SV *out = newSVpvn_flags("", 0, SVs_TEMP);
3121
3122     PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
3123
3124     nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
3125     s   = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
3126     len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
3127     if (!s) {
3128         s   = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
3129         len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
3130         sv_catpvs(out, "UTF8 ");
3131     }
3132     pv_pretty(out, s, len, 50,
3133                 NULL, NULL,
3134                 (PERL_PV_PRETTY_NOCLEAR
3135                 |PERL_PV_PRETTY_QUOTE
3136                 |PERL_PV_PRETTY_ELLIPSES));
3137
3138     lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3139     while (nargs-- >= 0) {
3140         Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
3141         lens++;
3142     }
3143     return out;
3144 }
3145
3146
3147 /*
3148 =for apidoc debop
3149
3150 Implements B<-Dt> perl command line option on OP C<o>.
3151
3152 =cut
3153 */
3154
3155 I32
3156 Perl_debop(pTHX_ const OP *o)
3157 {
3158     PERL_ARGS_ASSERT_DEBOP;
3159
3160     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
3161         return 0;
3162
3163     Perl_deb(aTHX_ "%s", OP_NAME(o));
3164     switch (o->op_type) {
3165     case OP_CONST:
3166     case OP_HINTSEVAL:
3167         /* With ITHREADS, consts are stored in the pad, and the right pad
3168          * may not be active here, so check.
3169          * Looks like only during compiling the pads are illegal.
3170          */
3171 #ifdef USE_ITHREADS
3172         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
3173 #endif
3174             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
3175         break;
3176     case OP_GVSV:
3177     case OP_GV:
3178         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3179                 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
3180         break;
3181
3182     case OP_PADSV:
3183     case OP_PADAV:
3184     case OP_PADHV:
3185     case OP_ARGELEM:
3186         S_deb_padvar(aTHX_ o->op_targ, 1, 1);
3187         break;
3188
3189     case OP_PADRANGE:
3190         S_deb_padvar(aTHX_ o->op_targ,
3191                         o->op_private & OPpPADRANGE_COUNTMASK, 1);
3192         break;
3193
3194     case OP_MULTIDEREF:
3195         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3196             SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
3197         break;
3198
3199     case OP_MULTICONCAT:
3200         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3201             SVfARG(multiconcat_stringify(o)));
3202         break;
3203
3204     default:
3205         break;
3206     }
3207     PerlIO_printf(Perl_debug_log, "\n");
3208     return 0;
3209 }
3210
3211
3212 /*
3213 =for apidoc op_class
3214
3215 Given an op, determine what type of struct it has been allocated as.
3216 Returns one of the OPclass enums, such as OPclass_LISTOP.
3217
3218 =cut
3219 */
3220
3221
3222 OPclass
3223 Perl_op_class(pTHX_ const OP *o)
3224 {
3225     bool custom = 0;
3226
3227     if (!o)
3228         return OPclass_NULL;
3229
3230     if (o->op_type == 0) {
3231         if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
3232             return OPclass_COP;
3233         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
3234     }
3235
3236     if (o->op_type == OP_SASSIGN)
3237         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
3238
3239     if (o->op_type == OP_AELEMFAST) {
3240 #ifdef USE_ITHREADS
3241             return OPclass_PADOP;
3242 #else
3243             return OPclass_SVOP;
3244 #endif
3245     }
3246
3247 #ifdef USE_ITHREADS
3248     if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
3249         o->op_type == OP_RCATLINE)
3250         return OPclass_PADOP;
3251 #endif
3252
3253     if (o->op_type == OP_CUSTOM)
3254         custom = 1;
3255
3256     switch (OP_CLASS(o)) {
3257     case OA_BASEOP:
3258         return OPclass_BASEOP;
3259
3260     case OA_UNOP:
3261         return OPclass_UNOP;
3262
3263     case OA_BINOP:
3264         return OPclass_BINOP;
3265
3266     case OA_LOGOP:
3267         return OPclass_LOGOP;
3268
3269     case OA_LISTOP:
3270         return OPclass_LISTOP;
3271
3272     case OA_PMOP:
3273         return OPclass_PMOP;
3274
3275     case OA_SVOP:
3276         return OPclass_SVOP;
3277
3278     case OA_PADOP:
3279         return OPclass_PADOP;
3280
3281     case OA_PVOP_OR_SVOP:
3282         /*
3283          * Character translations (tr///) are usually a PVOP, keeping a
3284          * pointer to a table of shorts used to look up translations.
3285          * Under utf8, however, a simple table isn't practical; instead,
3286          * the OP is an SVOP (or, under threads, a PADOP),
3287          * and the SV is an AV.
3288          */
3289         return (!custom &&
3290                    (o->op_private & OPpTRANS_USE_SVOP)
3291                )
3292 #if  defined(USE_ITHREADS)
3293                 ? OPclass_PADOP : OPclass_PVOP;
3294 #else
3295                 ? OPclass_SVOP : OPclass_PVOP;
3296 #endif
3297
3298     case OA_LOOP:
3299         return OPclass_LOOP;
3300
3301     case OA_COP:
3302         return OPclass_COP;
3303
3304     case OA_BASEOP_OR_UNOP:
3305         /*
3306          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
3307          * whether parens were seen. perly.y uses OPf_SPECIAL to
3308          * signal whether a BASEOP had empty parens or none.
3309          * Some other UNOPs are created later, though, so the best
3310          * test is OPf_KIDS, which is set in newUNOP.
3311          */
3312         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
3313
3314     case OA_FILESTATOP:
3315         /*
3316          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
3317          * the OPf_REF flag to distinguish between OP types instead of the
3318          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
3319          * return OPclass_UNOP so that walkoptree can find our children. If
3320          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
3321          * (no argument to the operator) it's an OP; with OPf_REF set it's
3322          * an SVOP (and op_sv is the GV for the filehandle argument).
3323          */
3324         return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
3325 #ifdef USE_ITHREADS
3326                 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
3327 #else
3328                 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
3329 #endif
3330     case OA_LOOPEXOP:
3331         /*
3332          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
3333          * label was omitted (in which case it's a BASEOP) or else a term was
3334          * seen. In this last case, all except goto are definitely PVOP but
3335          * goto is either a PVOP (with an ordinary constant label), an UNOP
3336          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
3337          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3338          * get set.
3339          */
3340         if (o->op_flags & OPf_STACKED)
3341             return OPclass_UNOP;
3342         else if (o->op_flags & OPf_SPECIAL)
3343             return OPclass_BASEOP;
3344         else
3345             return OPclass_PVOP;
3346     case OA_METHOP:
3347         return OPclass_METHOP;
3348     case OA_UNOP_AUX:
3349         return OPclass_UNOP_AUX;
3350     }
3351     Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3352          OP_NAME(o));
3353     return OPclass_BASEOP;
3354 }
3355
3356
3357
3358 STATIC CV*
3359 S_deb_curcv(pTHX_ I32 ix)
3360 {
3361     PERL_SI *si = PL_curstackinfo;
3362     for (; ix >=0; ix--) {
3363         const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3364
3365         if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3366             return cx->blk_sub.cv;
3367         else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
3368             return cx->blk_eval.cv;
3369         else if (ix == 0 && si->si_type == PERLSI_MAIN)
3370             return PL_main_cv;
3371         else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3372                && si->si_type == PERLSI_SORT)
3373         {
3374             /* fake sort sub; use CV of caller */
3375             si = si->si_prev;
3376             ix = si->si_cxix + 1;
3377         }
3378     }
3379     return NULL;
3380 }
3381
3382 void
3383 Perl_watch(pTHX_ char **addr)
3384 {
3385     PERL_ARGS_ASSERT_WATCH;
3386
3387     PL_watchaddr = addr;
3388     PL_watchok = *addr;
3389     PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
3390         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3391 }
3392
3393 /*
3394 =for apidoc debprof
3395
3396 Called to indicate that C<o> was executed, for profiling purposes under the
3397 C<-DP> command line option.
3398
3399 =cut
3400 */
3401
3402 STATIC void
3403 S_debprof(pTHX_ const OP *o)
3404 {
3405     PERL_ARGS_ASSERT_DEBPROF;
3406
3407     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
3408         return;
3409     if (!PL_profiledata)
3410         Newxz(PL_profiledata, MAXO, U32);
3411     ++PL_profiledata[o->op_type];
3412 }
3413
3414 /*
3415 =for apidoc debprofdump
3416
3417 Dumps the contents of the data collected by the C<-DP> perl command line
3418 option.
3419
3420 =cut
3421 */
3422
3423 void
3424 Perl_debprofdump(pTHX)
3425 {
3426     unsigned i;
3427     if (!PL_profiledata)
3428         return;
3429     for (i = 0; i < MAXO; i++) {
3430         if (PL_profiledata[i])
3431             PerlIO_printf(Perl_debug_log,
3432                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
3433                                        PL_op_name[i]);
3434     }
3435 }
3436
3437
3438 /*
3439  * ex: set ts=8 sts=4 sw=4 et:
3440  */