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_SLABBED, "SLABBED,"},
1778     {CVf_NAMED, "NAMED,"},
1779     {CVf_LEXICAL, "LEXICAL,"},
1780     {CVf_ISXSUB, "ISXSUB,"},
1781     {CVf_ANONCONST,        "ANONCONST,"},
1782     {CVf_SIGNATURE,        "SIGNATURE,"},
1783     {CVf_REFCOUNTED_ANYSV, "REFCOUNTED_ANYSV,"},
1784     {CVf_IsMETHOD,         "IsMETHOD,"}
1785
1786 };
1787
1788 const struct flag_to_name hv_flags_names[] = {
1789     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1790     {SVphv_LAZYDEL, "LAZYDEL,"},
1791     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1792     {SVf_AMAGIC, "OVERLOAD,"},
1793     {SVphv_CLONEABLE, "CLONEABLE,"}
1794 };
1795
1796 const struct flag_to_name gp_flags_names[] = {
1797     {GVf_INTRO, "INTRO,"},
1798     {GVf_MULTI, "MULTI,"},
1799     {GVf_ASSUMECV, "ASSUMECV,"},
1800 };
1801
1802 const struct flag_to_name gp_flags_imported_names[] = {
1803     {GVf_IMPORTED_SV, " SV"},
1804     {GVf_IMPORTED_AV, " AV"},
1805     {GVf_IMPORTED_HV, " HV"},
1806     {GVf_IMPORTED_CV, " CV"},
1807 };
1808
1809 /* NOTE: this structure is mostly duplicative of one generated by
1810  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1811  * the two. - Yves */
1812 const struct flag_to_name regexp_extflags_names[] = {
1813     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1814     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1815     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1816     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1817     {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1818     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1819     {RXf_PMf_NOCAPTURE,   "PMf_NOCAPURE,"},
1820     {RXf_IS_ANCHORED,     "IS_ANCHORED,"},
1821     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1822     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1823     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1824     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1825     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1826     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1827     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1828     {RXf_SPLIT,           "SPLIT,"},
1829     {RXf_COPY_DONE,       "COPY_DONE,"},
1830     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1831     {RXf_TAINTED,         "TAINTED,"},
1832     {RXf_START_ONLY,      "START_ONLY,"},
1833     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1834     {RXf_WHITE,           "WHITE,"},
1835     {RXf_NULL,            "NULL,"},
1836 };
1837
1838 /* NOTE: this structure is mostly duplicative of one generated by
1839  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1840  * the two. - Yves */
1841 const struct flag_to_name regexp_core_intflags_names[] = {
1842     {PREGf_SKIP,            "SKIP,"},
1843     {PREGf_IMPLICIT,        "IMPLICIT,"},
1844     {PREGf_NAUGHTY,         "NAUGHTY,"},
1845     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1846     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1847     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1848     {PREGf_NOSCAN,          "NOSCAN,"},
1849     {PREGf_GPOS_SEEN,       "GPOS_SEEN,"},
1850     {PREGf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1851     {PREGf_ANCH_MBOL,       "ANCH_MBOL,"},
1852     {PREGf_ANCH_SBOL,       "ANCH_SBOL,"},
1853     {PREGf_ANCH_GPOS,       "ANCH_GPOS,"},
1854 };
1855
1856 /* Minimum number of decimal digits to preserve the significand of NV.  */
1857 #ifdef USE_LONG_DOUBLE
1858 #  ifdef LDBL_DECIMAL_DIG
1859 #    define NV_DECIMAL_DIG      LDBL_DECIMAL_DIG
1860 #  endif
1861 #elif defined(USE_QUADMATH) && defined(I_QUADMATH)
1862 #  ifdef FLT128_DECIMAL_DIG
1863 #    define NV_DECIMAL_DIG      FLT128_DECIMAL_DIG
1864 #  endif
1865 #else  /* NV is double */
1866 #  ifdef DBL_DECIMAL_DIG
1867 #    define NV_DECIMAL_DIG      DBL_DECIMAL_DIG
1868 #  endif
1869 #endif
1870
1871 #ifndef NV_DECIMAL_DIG
1872 #  if defined(NV_MANT_DIG) && FLT_RADIX == 2
1873 /* NV_DECIMAL_DIG = ceil(1 + NV_MANT_DIG * log10(2)), where log10(2) is
1874    approx. 146/485.  This is precise enough up to 2620 bits */
1875 #    define NV_DECIMAL_DIG      (1 + (NV_MANT_DIG * 146 + 484) / 485)
1876 #  endif
1877 #endif
1878
1879 #ifndef NV_DECIMAL_DIG
1880 #  define NV_DECIMAL_DIG        (NV_DIG + 3) /* last resort */
1881 #endif
1882
1883 /* Perl_do_sv_dump():
1884  *
1885  * level:   amount to indent the output
1886  * sv:      the object to dump
1887  * nest:    the current level of recursion
1888  * maxnest: the maximum allowed level of recursion
1889  * dumpops: if true, also dump the ops associated with a CV
1890  * pvlim:   limit on the length of any strings that are output
1891  * */
1892
1893 void
1894 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1895 {
1896     SV *d;
1897     const char *s;
1898     U32 flags;
1899     U32 type;
1900
1901     PERL_ARGS_ASSERT_DO_SV_DUMP;
1902
1903     if (!sv) {
1904         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1905         return;
1906     }
1907
1908     flags = SvFLAGS(sv);
1909     type = SvTYPE(sv);
1910
1911     /* process general SV flags */
1912
1913     d = Perl_newSVpvf(aTHX_
1914                    "(0x%" UVxf ") at 0x%" UVxf "\n%*s  REFCNT = %" IVdf "\n%*s  FLAGS = (",
1915                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1916                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1917                    (int)(PL_dumpindent*level), "");
1918
1919     if ((flags & SVs_PADSTALE))
1920             sv_catpvs(d, "PADSTALE,");
1921     if ((flags & SVs_PADTMP))
1922             sv_catpvs(d, "PADTMP,");
1923     append_flags(d, flags, first_sv_flags_names);
1924     if (flags & SVf_ROK)  {
1925                                 sv_catpvs(d, "ROK,");
1926         if (SvWEAKREF(sv))      sv_catpvs(d, "WEAKREF,");
1927     }
1928     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1929     append_flags(d, flags, second_sv_flags_names);
1930     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1931                            && type != SVt_PVAV) {
1932         if (SvPCS_IMPORTED(sv))
1933                                 sv_catpvs(d, "PCS_IMPORTED,");
1934         else
1935                                 sv_catpvs(d, "SCREAM,");
1936     }
1937
1938     /* process type-specific SV flags */
1939
1940     switch (type) {
1941     case SVt_PVCV:
1942     case SVt_PVFM:
1943         append_flags(d, CvFLAGS(sv), cv_flags_names);
1944         break;
1945     case SVt_PVHV:
1946         append_flags(d, flags, hv_flags_names);
1947         break;
1948     case SVt_PVGV:
1949     case SVt_PVLV:
1950         if (isGV_with_GP(sv)) {
1951             append_flags(d, GvFLAGS(sv), gp_flags_names);
1952         }
1953         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1954             sv_catpvs(d, "IMPORT");
1955             if (GvIMPORTED(sv) == GVf_IMPORTED)
1956                 sv_catpvs(d, "ALL,");
1957             else {
1958                 sv_catpvs(d, "(");
1959                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1960                 sv_catpvs(d, " ),");
1961             }
1962         }
1963         /* FALLTHROUGH */
1964     case SVt_PVMG:
1965     default:
1966         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpvs(d, "IsUV,");
1967         break;
1968
1969     case SVt_PVAV:
1970         break;
1971     }
1972     /* SVphv_SHAREKEYS is also 0x20000000 */
1973     if ((type != SVt_PVHV) && SvUTF8(sv))
1974         sv_catpvs(d, "UTF8");
1975
1976     if (*(SvEND(d) - 1) == ',') {
1977         SvCUR_set(d, SvCUR(d) - 1);
1978         SvPVX(d)[SvCUR(d)] = '\0';
1979     }
1980     sv_catpvs(d, ")");
1981     s = SvPVX_const(d);
1982
1983     /* dump initial SV details */
1984
1985 #ifdef DEBUG_LEAKING_SCALARS
1986     Perl_dump_indent(aTHX_ level, file,
1987         "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1988         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1989         sv->sv_debug_line,
1990         sv->sv_debug_inpad ? "for" : "by",
1991         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1992         PTR2UV(sv->sv_debug_parent),
1993         sv->sv_debug_serial
1994     );
1995 #endif
1996     Perl_dump_indent(aTHX_ level, file, "SV = ");
1997
1998     /* Dump SV type */
1999
2000     if (type < SVt_LAST) {
2001         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
2002
2003         if (type ==  SVt_NULL) {
2004             SvREFCNT_dec_NN(d);
2005             return;
2006         }
2007     } else {
2008         PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
2009         SvREFCNT_dec_NN(d);
2010         return;
2011     }
2012
2013     /* Dump general SV fields */
2014
2015     if ((type >= SVt_PVIV && type <= SVt_PVLV
2016          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
2017         || (type == SVt_IV && !SvROK(sv))) {
2018         if (SvIsUV(sv)
2019                                      )
2020             Perl_dump_indent(aTHX_ level, file, "  UV = %" UVuf, (UV)SvUVX(sv));
2021         else
2022             Perl_dump_indent(aTHX_ level, file, "  IV = %" IVdf, (IV)SvIVX(sv));
2023         (void)PerlIO_putc(file, '\n');
2024     }
2025
2026     if ((type >= SVt_PVNV && type <= SVt_PVLV
2027          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
2028                || type == SVt_NV) {
2029         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2030         STORE_LC_NUMERIC_SET_STANDARD();
2031         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DECIMAL_DIG, SvNVX(sv));
2032         RESTORE_LC_NUMERIC();
2033     }
2034
2035     if (SvROK(sv)) {
2036         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%" UVxf "\n",
2037                                PTR2UV(SvRV(sv)));
2038         if (nest < maxnest)
2039             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
2040     }
2041
2042     if (type < SVt_PV) {
2043         SvREFCNT_dec_NN(d);
2044         return;
2045     }
2046
2047     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
2048      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
2049         const bool re = isREGEXP(sv);
2050         const char * const ptr =
2051             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2052         if (ptr) {
2053             STRLEN delta;
2054             if (SvOOK(sv)) {
2055                 SvOOK_offset(sv, delta);
2056                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %" UVuf "\n",
2057                                  (UV) delta);
2058             } else {
2059                 delta = 0;
2060             }
2061             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%" UVxf " ",
2062                                    PTR2UV(ptr));
2063             if (SvOOK(sv)) {
2064                 PerlIO_printf(file, "( %s . ) ",
2065                               _pv_display_for_dump(d, ptr - delta, delta, 0,
2066                                          pvlim));
2067             }
2068             if (type == SVt_INVLIST) {
2069                 PerlIO_printf(file, "\n");
2070                 /* 4 blanks indents 2 beyond the PV, etc */
2071                 _invlist_dump(file, level, "    ", sv);
2072             }
2073             else {
2074                 PerlIO_printf(file, "%s", _pv_display_for_dump(d, ptr, SvCUR(sv),
2075                                                      re ? 0 : SvLEN(sv),
2076                                                      pvlim));
2077                 if (SvUTF8(sv)) /* the 6?  \x{....} */
2078                     PerlIO_printf(file, " [UTF8 \"%s\"]",
2079                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
2080                                                         UNI_DISPLAY_QQ));
2081                 if (SvIsBOOL(sv))
2082                     PerlIO_printf(file, " [BOOL %s]", ptr == PL_Yes ? "PL_Yes" : "PL_No");
2083                 PerlIO_printf(file, "\n");
2084             }
2085             Perl_dump_indent(aTHX_ level, file, "  CUR = %" IVdf "\n", (IV)SvCUR(sv));
2086             if (re && type == SVt_PVLV)
2087                 /* LV-as-REGEXP usurps len field to store pointer to
2088                  * regexp struct */
2089                 Perl_dump_indent(aTHX_ level, file, "  REGEXP = 0x%" UVxf "\n",
2090                    PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
2091             else
2092                 Perl_dump_indent(aTHX_ level, file, "  LEN = %" IVdf "\n",
2093                                        (IV)SvLEN(sv));
2094 #ifdef PERL_COPY_ON_WRITE
2095             if (SvIsCOW(sv) && SvLEN(sv))
2096                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
2097                                        CowREFCNT(sv));
2098 #endif
2099         }
2100         else
2101             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
2102     }
2103
2104     if (type >= SVt_PVMG) {
2105         if (SvMAGIC(sv))
2106                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
2107         if (SvSTASH(sv))
2108             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
2109
2110         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
2111             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %" IVdf "\n",
2112                                    (IV)BmUSEFUL(sv));
2113         }
2114     }
2115
2116     /* Dump type-specific SV fields */
2117
2118     switch (type) {
2119     case SVt_PVAV:
2120         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf,
2121                                PTR2UV(AvARRAY(sv)));
2122         if (AvARRAY(sv) != AvALLOC(sv)) {
2123             PerlIO_printf(file, " (offset=%" IVdf ")\n",
2124                                 (IV)(AvARRAY(sv) - AvALLOC(sv)));
2125             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%" UVxf "\n",
2126                                    PTR2UV(AvALLOC(sv)));
2127         }
2128         else
2129             (void)PerlIO_putc(file, '\n');
2130         Perl_dump_indent(aTHX_ level, file, "  FILL = %" IVdf "\n",
2131                                (IV)AvFILLp(sv));
2132         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
2133                                (IV)AvMAX(sv));
2134         SvPVCLEAR(d);
2135         if (AvREAL(sv)) sv_catpvs(d, ",REAL");
2136         if (AvREIFY(sv))        sv_catpvs(d, ",REIFY");
2137         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
2138                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
2139         if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
2140             SSize_t count;
2141             SV **svp = AvARRAY(MUTABLE_AV(sv));
2142             for (count = 0;
2143                  count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
2144                  count++, svp++)
2145             {
2146                 SV* const elt = *svp;
2147                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
2148                                        (IV)count);
2149                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2150             }
2151         }
2152         break;
2153     case SVt_PVHV: {
2154         U32 totalkeys;
2155         if (HvHasAUX(sv)) {
2156             struct xpvhv_aux *const aux = HvAUX(sv);
2157             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %" UVuf "\n",
2158                              (UV)aux->xhv_aux_flags);
2159         }
2160         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
2161         totalkeys = HvTOTALKEYS(MUTABLE_HV(sv));
2162         if (totalkeys) {
2163             /* Show distribution of HEs in the ARRAY */
2164             int freq[200];
2165 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
2166             int i;
2167             int max = 0;
2168             U32 pow2 = 2;
2169             U32 keys = totalkeys;
2170             NV theoret, sum = 0;
2171
2172             PerlIO_printf(file, "  (");
2173             Zero(freq, FREQ_MAX + 1, int);
2174             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
2175                 HE* h;
2176                 int count = 0;
2177                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
2178                     count++;
2179                 if (count > FREQ_MAX)
2180                     count = FREQ_MAX;
2181                 freq[count]++;
2182                 if (max < count)
2183                     max = count;
2184             }
2185             for (i = 0; i <= max; i++) {
2186                 if (freq[i]) {
2187                     PerlIO_printf(file, "%d%s:%d", i,
2188                                   (i == FREQ_MAX) ? "+" : "",
2189                                   freq[i]);
2190                     if (i != max)
2191                         PerlIO_printf(file, ", ");
2192                 }
2193             }
2194             (void)PerlIO_putc(file, ')');
2195             /* The "quality" of a hash is defined as the total number of
2196                comparisons needed to access every element once, relative
2197                to the expected number needed for a random hash.
2198
2199                The total number of comparisons is equal to the sum of
2200                the squares of the number of entries in each bucket.
2201                For a random hash of n keys into k buckets, the expected
2202                value is
2203                                 n + n(n-1)/2k
2204             */
2205
2206             for (i = max; i > 0; i--) { /* Precision: count down. */
2207                 sum += freq[i] * i * i;
2208             }
2209             while ((keys = keys >> 1))
2210                 pow2 = pow2 << 1;
2211             theoret = totalkeys;
2212             theoret += theoret * (theoret-1)/pow2;
2213             (void)PerlIO_putc(file, '\n');
2214             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"
2215                                    NVff "%%", theoret/sum*100);
2216         }
2217         (void)PerlIO_putc(file, '\n');
2218         Perl_dump_indent(aTHX_ level, file, "  KEYS = %" IVdf "\n",
2219                                (IV)totalkeys);
2220         {
2221             STRLEN count = 0;
2222             HE **ents = HvARRAY(sv);
2223
2224             if (ents) {
2225                 HE *const *const last = ents + HvMAX(sv);
2226                 count = last + 1 - ents;
2227
2228                 do {
2229                     if (!*ents)
2230                         --count;
2231                 } while (++ents <= last);
2232             }
2233
2234             Perl_dump_indent(aTHX_ level, file, "  FILL = %" UVuf "\n",
2235                              (UV)count);
2236         }
2237         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
2238                                (IV)HvMAX(sv));
2239         if (HvHasAUX(sv)) {
2240             Perl_dump_indent(aTHX_ level, file, "  RITER = %" IVdf "\n",
2241                                    (IV)HvRITER_get(sv));
2242             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%" UVxf "\n",
2243                                    PTR2UV(HvEITER_get(sv)));
2244 #ifdef PERL_HASH_RANDOMIZE_KEYS
2245             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%" UVxf,
2246                                    (UV)HvRAND_get(sv));
2247             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2248                 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2249                                     (UV)HvLASTRAND_get(sv));
2250             }
2251 #endif
2252             (void)PerlIO_putc(file, '\n');
2253         }
2254         {
2255             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2256             if (mg && mg->mg_obj) {
2257                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2258             }
2259         }
2260         {
2261             const char * const hvname = HvNAME_get(sv);
2262             if (hvname) {
2263                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2264                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2265                                        generic_pv_escape( tmpsv, hvname,
2266                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
2267         }
2268         }
2269         if (HvHasAUX(sv)) {
2270             AV * const backrefs
2271                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2272             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2273             if (HvAUX(sv)->xhv_name_count)
2274                 Perl_dump_indent(aTHX_
2275                  level, file, "  NAMECOUNT = %" IVdf "\n",
2276                  (IV)HvAUX(sv)->xhv_name_count
2277                 );
2278             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2279                 const I32 count = HvAUX(sv)->xhv_name_count;
2280                 if (count) {
2281                     SV * const names = newSVpvs_flags("", SVs_TEMP);
2282                     /* The starting point is the first element if count is
2283                        positive and the second element if count is negative. */
2284                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2285                         + (count < 0 ? 1 : 0);
2286                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2287                         + (count < 0 ? -count : count);
2288                     while (hekp < endp) {
2289                         if (*hekp) {
2290                             SV *tmp = newSVpvs_flags("", SVs_TEMP);
2291                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2292                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2293                         } else {
2294                             /* This should never happen. */
2295                             sv_catpvs(names, ", (null)");
2296                         }
2297                         ++hekp;
2298                     }
2299                     Perl_dump_indent(aTHX_
2300                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
2301                     );
2302                 }
2303                 else {
2304                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2305                     const char *const hvename = HvENAME_get(sv);
2306                     Perl_dump_indent(aTHX_
2307                      level, file, "  ENAME = \"%s\"\n",
2308                      generic_pv_escape(tmp, hvename,
2309                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2310                 }
2311             }
2312             if (backrefs) {
2313                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%" UVxf "\n",
2314                                  PTR2UV(backrefs));
2315                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2316                            dumpops, pvlim);
2317             }
2318             if (meta) {
2319                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2320                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"
2321                                  UVxf ")\n",
2322                                  generic_pv_escape( tmpsv, meta->mro_which->name,
2323                                 meta->mro_which->length,
2324                                 (meta->mro_which->kflags & HVhek_UTF8)),
2325                                  PTR2UV(meta->mro_which));
2326                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"
2327                                  UVxf "\n",
2328                                  (UV)meta->cache_gen);
2329                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%" UVxf "\n",
2330                                  (UV)meta->pkg_gen);
2331                 if (meta->mro_linear_all) {
2332                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"
2333                                  UVxf "\n",
2334                                  PTR2UV(meta->mro_linear_all));
2335                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2336                            dumpops, pvlim);
2337                 }
2338                 if (meta->mro_linear_current) {
2339                     Perl_dump_indent(aTHX_ level, file,
2340                                  "  MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2341                                  PTR2UV(meta->mro_linear_current));
2342                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2343                            dumpops, pvlim);
2344                 }
2345                 if (meta->mro_nextmethod) {
2346                     Perl_dump_indent(aTHX_ level, file,
2347                                  "  MRO_NEXTMETHOD = 0x%" UVxf "\n",
2348                                  PTR2UV(meta->mro_nextmethod));
2349                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2350                            dumpops, pvlim);
2351                 }
2352                 if (meta->isa) {
2353                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%" UVxf "\n",
2354                                  PTR2UV(meta->isa));
2355                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2356                            dumpops, pvlim);
2357                 }
2358             }
2359         }
2360         if (nest < maxnest) {
2361             HV * const hv = MUTABLE_HV(sv);
2362
2363             if (HvTOTALKEYS(hv)) {
2364                 STRLEN i;
2365                 int count = maxnest - nest;
2366                 for (i=0; i <= HvMAX(hv); i++) {
2367                     HE *he;
2368                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2369                         U32 hash;
2370                         SV * keysv;
2371                         const char * keypv;
2372                         SV * elt;
2373                         STRLEN len;
2374
2375                         if (count-- <= 0) goto DONEHV;
2376
2377                         hash = HeHASH(he);
2378                         keysv = hv_iterkeysv(he);
2379                         keypv = SvPV_const(keysv, len);
2380                         elt = HeVAL(he);
2381
2382                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", _pv_display_for_dump(d, keypv, len, 0, pvlim));
2383                         if (SvUTF8(keysv))
2384                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2385                         if (HvEITER_get(hv) == he)
2386                             PerlIO_printf(file, "[CURRENT] ");
2387                         PerlIO_printf(file, "HASH = 0x%" UVxf, (UV) hash);
2388
2389                         if (sv == (SV*)PL_strtab)
2390                             PerlIO_printf(file, " REFCNT = 0x%" UVxf "\n",
2391                                 (UV)he->he_valu.hent_refcount );
2392                         else {
2393                             (void)PerlIO_putc(file, '\n');
2394                             do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2395                         }
2396                     }
2397                 }
2398               DONEHV:;
2399             }
2400         }
2401         break;
2402     } /* case SVt_PVHV */
2403
2404     case SVt_PVCV:
2405         if (CvAUTOLOAD(sv)) {
2406             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2407             STRLEN len;
2408             const char *const name =  SvPV_const(sv, len);
2409             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
2410                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2411         }
2412         if (SvPOK(sv)) {
2413             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2414             const char *const proto = CvPROTO(sv);
2415             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
2416                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2417                                 SvUTF8(sv)));
2418         }
2419         /* FALLTHROUGH */
2420     case SVt_PVFM:
2421         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
2422         if (!CvISXSUB(sv)) {
2423             if (CvSTART(sv)) {
2424                 if (CvSLABBED(sv))
2425                     Perl_dump_indent(aTHX_ level, file,
2426                                  "  SLAB = 0x%" UVxf "\n",
2427                                  PTR2UV(CvSTART(sv)));
2428                 else
2429                     Perl_dump_indent(aTHX_ level, file,
2430                                  "  START = 0x%" UVxf " ===> %" IVdf "\n",
2431                                  PTR2UV(CvSTART(sv)),
2432                                  (IV)sequence_num(CvSTART(sv)));
2433             }
2434             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%" UVxf "\n",
2435                              PTR2UV(CvROOT(sv)));
2436             if (CvROOT(sv) && dumpops) {
2437                 do_op_dump(level+1, file, CvROOT(sv));
2438             }
2439         } else {
2440             SV * const constant = cv_const_sv((const CV *)sv);
2441
2442             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2443
2444             if (constant) {
2445                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%" UVxf
2446                                  " (CONST SV)\n",
2447                                  PTR2UV(CvXSUBANY(sv).any_ptr));
2448                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2449                            pvlim);
2450             } else {
2451                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %" IVdf "\n",
2452                                  (IV)CvXSUBANY(sv).any_i32);
2453             }
2454         }
2455         if (CvNAMED(sv))
2456             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2457                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
2458         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
2459         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
2460         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"
2461                                       IVdf "\n", (IV)CvDEPTH(sv));
2462         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n",
2463                                (UV)CvFLAGS(sv));
2464         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2465         if (!CvISXSUB(sv)) {
2466             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2467             if (nest < maxnest) {
2468                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2469             }
2470         }
2471         else
2472             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
2473         {
2474             const CV * const outside = CvOUTSIDE(sv);
2475             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%" UVxf " (%s)\n",
2476                         PTR2UV(outside),
2477                         (!outside ? "null"
2478                          : CvANON(outside) ? "ANON"
2479                          : (outside == PL_main_cv) ? "MAIN"
2480                          : CvUNIQUE(outside) ? "UNIQUE"
2481                          : CvGV(outside) ?
2482                              generic_pv_escape(
2483                                  newSVpvs_flags("", SVs_TEMP),
2484                                  GvNAME(CvGV(outside)),
2485                                  GvNAMELEN(CvGV(outside)),
2486                                  GvNAMEUTF8(CvGV(outside)))
2487                          : "UNDEFINED"));
2488         }
2489         if (CvOUTSIDE(sv)
2490          && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2491             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2492         break;
2493
2494     case SVt_PVGV:
2495     case SVt_PVLV:
2496         if (type == SVt_PVLV) {
2497             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2498             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2499             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2500             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2501             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2502             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2503                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2504                     dumpops, pvlim);
2505         }
2506         if (isREGEXP(sv)) goto dumpregexp;
2507         if (!isGV_with_GP(sv))
2508             break;
2509         {
2510             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2511             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2512                      generic_pv_escape(tmpsv, GvNAME(sv),
2513                                        GvNAMELEN(sv),
2514                                        GvNAMEUTF8(sv)));
2515         }
2516         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2517         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2518         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2519         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2520         if (!GvGP(sv))
2521             break;
2522         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2523         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2524         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2525         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%" UVxf "  \n", PTR2UV(GvFORM(sv)));
2526         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2527         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2528         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2529         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2530         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%" UVxf
2531                                             " (%s)\n",
2532                                (UV)GvGPFLAGS(sv),
2533                                "");
2534         Perl_dump_indent(aTHX_ level, file, "    LINE = %" LINE_Tf "\n", (line_t)GvLINE(sv));
2535         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2536         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2537         break;
2538     case SVt_PVIO:
2539         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2540         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2541         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2542         Perl_dump_indent(aTHX_ level, file, "  LINES = %" IVdf "\n", (IV)IoLINES(sv));
2543         Perl_dump_indent(aTHX_ level, file, "  PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2544         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2545         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2546         if (IoTOP_NAME(sv))
2547             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2548         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2549             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2550         else {
2551             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%" UVxf "\n",
2552                              PTR2UV(IoTOP_GV(sv)));
2553             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2554                         maxnest, dumpops, pvlim);
2555         }
2556         /* Source filters hide things that are not GVs in these three, so let's
2557            be careful out there.  */
2558         if (IoFMT_NAME(sv))
2559             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2560         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2561             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2562         else {
2563             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%" UVxf "\n",
2564                              PTR2UV(IoFMT_GV(sv)));
2565             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2566                         maxnest, dumpops, pvlim);
2567         }
2568         if (IoBOTTOM_NAME(sv))
2569             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2570         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2571             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2572         else {
2573             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%" UVxf "\n",
2574                              PTR2UV(IoBOTTOM_GV(sv)));
2575             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2576                         maxnest, dumpops, pvlim);
2577         }
2578         if (isPRINT(IoTYPE(sv)))
2579             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2580         else
2581             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2582         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2583         break;
2584     case SVt_REGEXP:
2585       dumpregexp:
2586         {
2587             struct regexp * const r = ReANY((REGEXP*)sv);
2588
2589 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2590             sv_setpv(d,"");                                 \
2591             append_flags(d, flags, names);     \
2592             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2593                 SvCUR_set(d, SvCUR(d) - 1);                 \
2594                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2595             }                                               \
2596 } STMT_END
2597             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2598             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%" UVxf " (%s)\n",
2599                                 (UV)(r->compflags), SvPVX_const(d));
2600
2601             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2602             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%" UVxf " (%s)\n",
2603                                 (UV)(r->extflags), SvPVX_const(d));
2604
2605             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%" UVxf " (%s)\n",
2606                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2607             if (r->engine == &PL_core_reg_engine) {
2608                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2609                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf " (%s)\n",
2610                                 (UV)(r->intflags), SvPVX_const(d));
2611             } else {
2612                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf "(Plug in)\n",
2613                                 (UV)(r->intflags));
2614             }
2615 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2616             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %" UVuf "\n",
2617                                 (UV)(r->nparens));
2618             Perl_dump_indent(aTHX_ level, file, "  LOGICAL_NPARENS = %" UVuf "\n",
2619                                 (UV)(r->logical_nparens));
2620
2621 #define SV_SET_STRINGIFY_I32_PAREN_ARRAY(d,count,ary)     \
2622     STMT_START {                                    \
2623         U32 n;                                      \
2624         sv_setpv(d,"{ ");                           \
2625         /* 0 element is irrelevant */               \
2626         for(n=0; n <= count; n++)                   \
2627             sv_catpvf(d,"%" IVdf "%s",              \
2628                 (IV)ary[n],                         \
2629                 n == count ? "" : ", ");            \
2630         sv_catpvs(d," }\n");                        \
2631     } STMT_END
2632
2633             Perl_dump_indent(aTHX_ level, file, "  LOGICAL_TO_PARNO = 0x%" UVxf "\n",
2634                                 PTR2UV(r->logical_to_parno));
2635             if (r->logical_to_parno) {
2636                 SV_SET_STRINGIFY_I32_PAREN_ARRAY(d, r->logical_nparens, r->logical_to_parno);
2637                 Perl_dump_indent(aTHX_ level, file, "    %" SVf, d);
2638             }
2639             Perl_dump_indent(aTHX_ level, file, "  PARNO_TO_LOGICAL = 0x%" UVxf "\n",
2640                                 PTR2UV(r->parno_to_logical));
2641             if (r->parno_to_logical) {
2642                 SV_SET_STRINGIFY_I32_PAREN_ARRAY(d, r->nparens, r->parno_to_logical);
2643                 Perl_dump_indent(aTHX_ level, file, "    %" SVf, d);
2644             }
2645
2646             Perl_dump_indent(aTHX_ level, file, "  PARNO_TO_LOGICAL_NEXT = 0x%" UVxf "\n",
2647                                 PTR2UV(r->parno_to_logical_next));
2648             if (r->parno_to_logical_next) {
2649                 SV_SET_STRINGIFY_I32_PAREN_ARRAY(d, r->nparens, r->parno_to_logical_next);
2650                 Perl_dump_indent(aTHX_ level, file, "    %" SVf, d);
2651             }
2652 #undef SV_SET_STRINGIFY_I32_ARRAY
2653
2654             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %" UVuf "\n",
2655                                 (UV)(RXp_LASTPAREN(r)));
2656             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %" UVuf "\n",
2657                                 (UV)(RXp_LASTCLOSEPAREN(r)));
2658             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %" IVdf "\n",
2659                                 (IV)(RXp_MINLEN(r)));
2660             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %" IVdf "\n",
2661                                 (IV)(RXp_MINLENRET(r)));
2662             Perl_dump_indent(aTHX_ level, file, "  GOFS = %" UVuf "\n",
2663                                 (UV)(RXp_GOFS(r)));
2664             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %" UVuf "\n",
2665                                 (UV)(RXp_PRE_PREFIX(r)));
2666             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %" IVdf "\n",
2667                                 (IV)(RXp_SUBLEN(r)));
2668             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %" IVdf "\n",
2669                                 (IV)(RXp_SUBOFFSET(r)));
2670             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %" IVdf "\n",
2671                                 (IV)(RXp_SUBCOFFSET(r)));
2672             if (RXp_SUBBEG(r))
2673                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%" UVxf " %s\n",
2674                             PTR2UV(RXp_SUBBEG(r)),
2675                             pv_display(d, RXp_SUBBEG(r), RXp_SUBLEN(r), 50, pvlim));
2676             else
2677                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2678             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%" UVxf "\n",
2679                                 PTR2UV(RXp_PAREN_NAMES(r)));
2680             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%" UVxf "\n",
2681                                 PTR2UV(RXp_SUBSTRS(r)));
2682             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%" UVxf "\n",
2683                                 PTR2UV(RXp_PPRIVATE(r)));
2684             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%" UVxf "\n",
2685                                 PTR2UV(RXp_OFFSp(r)));
2686             if (RXp_OFFSp(r)) {
2687                 U32 n;
2688                 sv_setpvs(d,"[ ");
2689                 /* note offs[0] is for the whole match, and
2690                  * the data for $1 is in offs[1]. Thus we have to
2691                  * show one more than we have nparens. */
2692                 for(n = 0; n <= r->nparens; n++) {
2693                     sv_catpvf(d,"%" IVdf ":%" IVdf "%s",
2694                         (IV)RXp_OFFSp(r)[n].start, (IV)RXp_OFFSp(r)[n].end,
2695                         n+1 > r->nparens ? " ]\n" : ", ");
2696                 }
2697                 Perl_dump_indent(aTHX_ level, file, "    %" SVf, d);
2698             }
2699             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%" UVxf "\n",
2700                                 PTR2UV(RXp_QR_ANONCV(r)));
2701 #ifdef PERL_ANY_COW
2702             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%" UVxf "\n",
2703                                 PTR2UV(RXp_SAVED_COPY(r)));
2704 #endif
2705             /* this should go LAST or the output gets really confusing */
2706             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%" UVxf "\n",
2707                                 PTR2UV(RXp_MOTHER_RE(r)));
2708             if (nest < maxnest && RXp_MOTHER_RE(r))
2709                 do_sv_dump(level+1, file, (SV *)RXp_MOTHER_RE(r), nest+1,
2710                            maxnest, dumpops, pvlim);
2711         }
2712         break;
2713     case SVt_PVOBJ:
2714         Perl_dump_indent(aTHX_ level, file, "  MAXFIELD = %" IVdf "\n",
2715                 (IV)ObjectMAXFIELD(sv));
2716         Perl_dump_indent(aTHX_ level, file, "  FIELDS = 0x%" UVxf "\n",
2717                 PTR2UV(ObjectFIELDS(sv)));
2718         if (nest < maxnest && ObjectFIELDS(sv)) {
2719             SSize_t count;
2720             SV **svp = ObjectFIELDS(sv);
2721             PADNAME **pname = PadnamelistARRAY(HvAUX(SvSTASH(sv))->xhv_class_fields);
2722             for (count = 0;
2723                  count <= ObjectMAXFIELD(sv) && count < maxnest;
2724                  count++, svp++)
2725             {
2726                 SV *const field = *svp;
2727                 PADNAME *pn = pname[count];
2728
2729                 Perl_dump_indent(aTHX_ level + 1, file, "Field No. %" IVdf " (%s)\n",
2730                         (IV)count, PadnamePV(pn));
2731
2732                 do_sv_dump(level+1, file, field, nest+1, maxnest, dumpops, pvlim);
2733             }
2734         }
2735         break;
2736     }
2737     SvREFCNT_dec_NN(d);
2738 }
2739
2740 /*
2741 =for apidoc sv_dump
2742
2743 Dumps the contents of an SV to the C<STDERR> filehandle.
2744
2745 For an example of its output, see L<Devel::Peek>. If
2746 the item is an SvROK it will dump items to a depth of 4,
2747 otherwise it will dump only the top level item, which
2748 means that it will not dump the contents of an AV * or
2749 HV *. For that use C<av_dump()> or C<hv_dump()>.
2750
2751 =for apidoc sv_dump_depth
2752
2753 Dumps the contents of an SV to the C<STDERR> filehandle
2754 to the depth requested. This function can be used on any
2755 SV derived type (GV, HV, AV) with an appropriate cast.
2756 This is a more flexible variant of sv_dump(). For example
2757
2758     HV *hv = ...;
2759     sv_dump_depth((SV*)hv, 2);
2760
2761 would dump the hv, its keys and values, but would not recurse
2762 into any RV values.
2763
2764 =for apidoc av_dump
2765
2766 Dumps the contents of an AV to the C<STDERR> filehandle,
2767 Similar to using Devel::Peek on an arrayref but does not
2768 expect an RV wrapper. Dumps contents to a depth of 3 levels
2769 deep.
2770
2771 =for apidoc hv_dump
2772
2773 Dumps the contents of an HV to the C<STDERR> filehandle.
2774 Similar to using Devel::Peek on an hashref but does not
2775 expect an RV wrapper. Dumps contents to a depth of 3 levels
2776 deep.
2777
2778 =cut
2779 */
2780
2781 void
2782 Perl_sv_dump(pTHX_ SV *sv)
2783 {
2784     if (sv && SvROK(sv))
2785         sv_dump_depth(sv, 4);
2786     else
2787         sv_dump_depth(sv, 0);
2788 }
2789
2790 void
2791 Perl_sv_dump_depth(pTHX_ SV *sv, I32 depth)
2792 {
2793     do_sv_dump(0, Perl_debug_log, sv, 0, depth, 0, 0);
2794 }
2795
2796 void
2797 Perl_av_dump(pTHX_ AV *av)
2798 {
2799     sv_dump_depth((SV*)av, 3);
2800 }
2801
2802 void
2803 Perl_hv_dump(pTHX_ HV *hv)
2804 {
2805     sv_dump_depth((SV*)hv, 3);
2806 }
2807
2808 int
2809 Perl_runops_debug(pTHX)
2810 {
2811 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2812     SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2813
2814     PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2815 #endif
2816
2817 #ifdef PERL_RC_STACK
2818     assert(rpp_stack_is_rc());
2819     assert(PL_stack_base + PL_curstackinfo->si_stack_nonrc_base
2820                 <= PL_stack_sp);
2821 #endif
2822
2823     if (!PL_op) {
2824         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2825         return 0;
2826     }
2827     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2828     do {
2829 #ifdef PERL_TRACE_OPS
2830         ++PL_op_exec_cnt[PL_op->op_type];
2831 #endif
2832 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2833         if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2834             Perl_croak_nocontext(
2835                 "panic: previous op failed to extend arg stack: "
2836                 "base=%p, sp=%p, hwm=%p\n",
2837                     PL_stack_base, PL_stack_sp,
2838                     PL_stack_base + PL_curstackinfo->si_stack_hwm);
2839         PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2840 #endif
2841         if (PL_debug) {
2842             ENTER;
2843             SAVETMPS;
2844             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2845                 PerlIO_printf(Perl_debug_log,
2846                               "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2847                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2848                               PTR2UV(*PL_watchaddr));
2849             if (DEBUG_s_TEST_) {
2850                 if (DEBUG_v_TEST_) {
2851                     PerlIO_printf(Perl_debug_log, "\n");
2852                     deb_stack_all();
2853                 }
2854                 else
2855                     debstack();
2856             }
2857
2858
2859             if (DEBUG_t_TEST_) debop(PL_op);
2860             if (DEBUG_P_TEST_) debprof(PL_op);
2861             FREETMPS;
2862             LEAVE;
2863         }
2864
2865         PERL_DTRACE_PROBE_OP(PL_op);
2866     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2867     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2868     PERL_ASYNC_CHECK();
2869
2870 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2871     if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2872         PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2873 #endif
2874     TAINT_NOT;
2875     return 0;
2876 }
2877
2878
2879 /* print the names of the n lexical vars starting at pad offset off */
2880
2881 STATIC void
2882 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2883 {
2884     PADNAME *sv;
2885     CV * const cv = deb_curcv(cxstack_ix);
2886     PADNAMELIST *comppad = NULL;
2887     int i;
2888
2889     if (cv) {
2890         PADLIST * const padlist = CvPADLIST(cv);
2891         comppad = PadlistNAMES(padlist);
2892     }
2893     if (paren)
2894         PerlIO_printf(Perl_debug_log, "(");
2895     for (i = 0; i < n; i++) {
2896         if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2897             PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2898         else
2899             PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2900                     (UV)(off+i));
2901         if (i < n - 1)
2902             PerlIO_printf(Perl_debug_log, ",");
2903     }
2904     if (paren)
2905         PerlIO_printf(Perl_debug_log, ")");
2906 }
2907
2908
2909 /* append to the out SV, the name of the lexical at offset off in the CV
2910  * cv */
2911
2912 static void
2913 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2914         bool paren, bool is_scalar)
2915 {
2916     PADNAME *sv;
2917     PADNAMELIST *namepad = NULL;
2918     int i;
2919
2920     if (cv) {
2921         PADLIST * const padlist = CvPADLIST(cv);
2922         namepad = PadlistNAMES(padlist);
2923     }
2924
2925     if (paren)
2926         sv_catpvs_nomg(out, "(");
2927     for (i = 0; i < n; i++) {
2928         if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2929         {
2930             STRLEN cur = SvCUR(out);
2931             Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2932                                  UTF8fARG(1, PadnameLEN(sv) - 1,
2933                                           PadnamePV(sv) + 1));
2934             if (is_scalar)
2935                 SvPVX(out)[cur] = '$';
2936         }
2937         else
2938             Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2939         if (i < n - 1)
2940             sv_catpvs_nomg(out, ",");
2941     }
2942     if (paren)
2943         sv_catpvs_nomg(out, "(");
2944 }
2945
2946
2947 static void
2948 S_append_gv_name(pTHX_ GV *gv, SV *out)
2949 {
2950     SV *sv;
2951     if (!gv) {
2952         sv_catpvs_nomg(out, "<NULLGV>");
2953         return;
2954     }
2955     sv = newSV_type(SVt_NULL);
2956     gv_fullname4(sv, gv, NULL, FALSE);
2957     Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2958     SvREFCNT_dec_NN(sv);
2959 }
2960
2961 #ifdef USE_ITHREADS
2962 #  define ITEM_SV(item) (comppad ? \
2963     *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2964 #else
2965 #  define ITEM_SV(item) UNOP_AUX_item_sv(item)
2966 #endif
2967
2968
2969 /* return a temporary SV containing a stringified representation of
2970  * the op_aux field of a MULTIDEREF op, associated with CV cv
2971  */
2972
2973 SV*
2974 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2975 {
2976     UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2977     UV actions = items->uv;
2978     SV *sv;
2979     bool last = 0;
2980     bool is_hash = FALSE;
2981     int derefs = 0;
2982     SV *out = newSVpvn_flags("",0,SVs_TEMP);
2983 #ifdef USE_ITHREADS
2984     PAD *comppad;
2985
2986     if (cv) {
2987         PADLIST *padlist = CvPADLIST(cv);
2988         comppad = PadlistARRAY(padlist)[1];
2989     }
2990     else
2991         comppad = NULL;
2992 #endif
2993
2994     PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2995
2996     while (!last) {
2997         switch (actions & MDEREF_ACTION_MASK) {
2998
2999         case MDEREF_reload:
3000             actions = (++items)->uv;
3001             continue;
3002             NOT_REACHED; /* NOTREACHED */
3003
3004         case MDEREF_HV_padhv_helem:
3005             is_hash = TRUE;
3006             /* FALLTHROUGH */
3007         case MDEREF_AV_padav_aelem:
3008             derefs = 1;
3009             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
3010             goto do_elem;
3011             NOT_REACHED; /* NOTREACHED */
3012
3013         case MDEREF_HV_gvhv_helem:
3014             is_hash = TRUE;
3015             /* FALLTHROUGH */
3016         case MDEREF_AV_gvav_aelem:
3017             derefs = 1;
3018             items++;
3019             sv = ITEM_SV(items);
3020             S_append_gv_name(aTHX_ (GV*)sv, out);
3021             goto do_elem;
3022             NOT_REACHED; /* NOTREACHED */
3023
3024         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
3025             is_hash = TRUE;
3026             /* FALLTHROUGH */
3027         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
3028             items++;
3029             sv = ITEM_SV(items);
3030             S_append_gv_name(aTHX_ (GV*)sv, out);
3031             goto do_vivify_rv2xv_elem;
3032             NOT_REACHED; /* NOTREACHED */
3033
3034         case MDEREF_HV_padsv_vivify_rv2hv_helem:
3035             is_hash = TRUE;
3036             /* FALLTHROUGH */
3037         case MDEREF_AV_padsv_vivify_rv2av_aelem:
3038             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
3039             goto do_vivify_rv2xv_elem;
3040             NOT_REACHED; /* NOTREACHED */
3041
3042         case MDEREF_HV_pop_rv2hv_helem:
3043         case MDEREF_HV_vivify_rv2hv_helem:
3044             is_hash = TRUE;
3045             /* FALLTHROUGH */
3046         do_vivify_rv2xv_elem:
3047         case MDEREF_AV_pop_rv2av_aelem:
3048         case MDEREF_AV_vivify_rv2av_aelem:
3049             if (!derefs++)
3050                 sv_catpvs_nomg(out, "->");
3051         do_elem:
3052             if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
3053                 sv_catpvs_nomg(out, "->");
3054                 last = 1;
3055                 break;
3056             }
3057
3058             sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
3059             switch (actions & MDEREF_INDEX_MASK) {
3060             case MDEREF_INDEX_const:
3061                 if (is_hash) {
3062                     items++;
3063                     sv = ITEM_SV(items);
3064                     if (!sv)
3065                         sv_catpvs_nomg(out, "???");
3066                     else {
3067                         STRLEN cur;
3068                         char *s;
3069                         s = SvPV(sv, cur);
3070                         pv_pretty(out, s, cur, 30,
3071                                     NULL, NULL,
3072                                     (PERL_PV_PRETTY_NOCLEAR
3073                                     |PERL_PV_PRETTY_QUOTE
3074                                     |PERL_PV_PRETTY_ELLIPSES));
3075                     }
3076                 }
3077                 else
3078                     Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
3079                 break;
3080             case MDEREF_INDEX_padsv:
3081                 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
3082                 break;
3083             case MDEREF_INDEX_gvsv:
3084                 items++;
3085                 sv = ITEM_SV(items);
3086                 S_append_gv_name(aTHX_ (GV*)sv, out);
3087                 break;
3088             }
3089             sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
3090
3091             if (actions & MDEREF_FLAG_last)
3092                 last = 1;
3093             is_hash = FALSE;
3094
3095             break;
3096
3097         default:
3098             PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
3099                 (int)(actions & MDEREF_ACTION_MASK));
3100             last = 1;
3101             break;
3102
3103         } /* switch */
3104
3105         actions >>= MDEREF_SHIFT;
3106     } /* while */
3107     return out;
3108 }
3109
3110
3111 /* Return a temporary SV containing a stringified representation of
3112  * the op_aux field of a MULTICONCAT op. Note that if the aux contains
3113  * both plain and utf8 versions of the const string and indices, only
3114  * the first is displayed.
3115  */
3116
3117 SV*
3118 Perl_multiconcat_stringify(pTHX_ const OP *o)
3119 {
3120     UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
3121     UNOP_AUX_item *lens;
3122     STRLEN len;
3123     SSize_t nargs;
3124     char *s;
3125     SV *out = newSVpvn_flags("", 0, SVs_TEMP);
3126
3127     PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
3128
3129     nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
3130     s   = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
3131     len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
3132     if (!s) {
3133         s   = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
3134         len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
3135         sv_catpvs(out, "UTF8 ");
3136     }
3137     pv_pretty(out, s, len, 50,
3138                 NULL, NULL,
3139                 (PERL_PV_PRETTY_NOCLEAR
3140                 |PERL_PV_PRETTY_QUOTE
3141                 |PERL_PV_PRETTY_ELLIPSES));
3142
3143     lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
3144     while (nargs-- >= 0) {
3145         Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
3146         lens++;
3147     }
3148     return out;
3149 }
3150
3151
3152 /*
3153 =for apidoc debop
3154
3155 Implements B<-Dt> perl command line option on OP C<o>.
3156
3157 =cut
3158 */
3159
3160 I32
3161 Perl_debop(pTHX_ const OP *o)
3162 {
3163     PERL_ARGS_ASSERT_DEBOP;
3164
3165     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
3166         return 0;
3167
3168     Perl_deb(aTHX_ "%s", OP_NAME(o));
3169     switch (o->op_type) {
3170     case OP_CONST:
3171     case OP_HINTSEVAL:
3172         /* With ITHREADS, consts are stored in the pad, and the right pad
3173          * may not be active here, so check.
3174          * Looks like only during compiling the pads are illegal.
3175          */
3176 #ifdef USE_ITHREADS
3177         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
3178 #endif
3179             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
3180         break;
3181     case OP_GVSV:
3182     case OP_GV:
3183         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3184                 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
3185         break;
3186
3187     case OP_PADSV:
3188     case OP_PADAV:
3189     case OP_PADHV:
3190     case OP_ARGELEM:
3191         S_deb_padvar(aTHX_ o->op_targ, 1, 1);
3192         break;
3193
3194     case OP_PADRANGE:
3195         S_deb_padvar(aTHX_ o->op_targ,
3196                         o->op_private & OPpPADRANGE_COUNTMASK, 1);
3197         break;
3198
3199     case OP_MULTIDEREF:
3200         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3201             SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
3202         break;
3203
3204     case OP_MULTICONCAT:
3205         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
3206             SVfARG(multiconcat_stringify(o)));
3207         break;
3208
3209     default:
3210         break;
3211     }
3212     PerlIO_printf(Perl_debug_log, "\n");
3213     return 0;
3214 }
3215
3216
3217 /*
3218 =for apidoc op_class
3219
3220 Given an op, determine what type of struct it has been allocated as.
3221 Returns one of the OPclass enums, such as OPclass_LISTOP.
3222
3223 =cut
3224 */
3225
3226
3227 OPclass
3228 Perl_op_class(pTHX_ const OP *o)
3229 {
3230     bool custom = 0;
3231
3232     if (!o)
3233         return OPclass_NULL;
3234
3235     if (o->op_type == 0) {
3236         if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
3237             return OPclass_COP;
3238         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
3239     }
3240
3241     if (o->op_type == OP_SASSIGN)
3242         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
3243
3244     if (o->op_type == OP_AELEMFAST) {
3245 #ifdef USE_ITHREADS
3246             return OPclass_PADOP;
3247 #else
3248             return OPclass_SVOP;
3249 #endif
3250     }
3251
3252 #ifdef USE_ITHREADS
3253     if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
3254         o->op_type == OP_RCATLINE)
3255         return OPclass_PADOP;
3256 #endif
3257
3258     if (o->op_type == OP_CUSTOM)
3259         custom = 1;
3260
3261     switch (OP_CLASS(o)) {
3262     case OA_BASEOP:
3263         return OPclass_BASEOP;
3264
3265     case OA_UNOP:
3266         return OPclass_UNOP;
3267
3268     case OA_BINOP:
3269         return OPclass_BINOP;
3270
3271     case OA_LOGOP:
3272         return OPclass_LOGOP;
3273
3274     case OA_LISTOP:
3275         return OPclass_LISTOP;
3276
3277     case OA_PMOP:
3278         return OPclass_PMOP;
3279
3280     case OA_SVOP:
3281         return OPclass_SVOP;
3282
3283     case OA_PADOP:
3284         return OPclass_PADOP;
3285
3286     case OA_PVOP_OR_SVOP:
3287         /*
3288          * Character translations (tr///) are usually a PVOP, keeping a
3289          * pointer to a table of shorts used to look up translations.
3290          * Under utf8, however, a simple table isn't practical; instead,
3291          * the OP is an SVOP (or, under threads, a PADOP),
3292          * and the SV is an AV.
3293          */
3294         return (!custom &&
3295                    (o->op_private & OPpTRANS_USE_SVOP)
3296                )
3297 #if  defined(USE_ITHREADS)
3298                 ? OPclass_PADOP : OPclass_PVOP;
3299 #else
3300                 ? OPclass_SVOP : OPclass_PVOP;
3301 #endif
3302
3303     case OA_LOOP:
3304         return OPclass_LOOP;
3305
3306     case OA_COP:
3307         return OPclass_COP;
3308
3309     case OA_BASEOP_OR_UNOP:
3310         /*
3311          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
3312          * whether parens were seen. perly.y uses OPf_SPECIAL to
3313          * signal whether a BASEOP had empty parens or none.
3314          * Some other UNOPs are created later, though, so the best
3315          * test is OPf_KIDS, which is set in newUNOP.
3316          */
3317         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
3318
3319     case OA_FILESTATOP:
3320         /*
3321          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
3322          * the OPf_REF flag to distinguish between OP types instead of the
3323          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
3324          * return OPclass_UNOP so that walkoptree can find our children. If
3325          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
3326          * (no argument to the operator) it's an OP; with OPf_REF set it's
3327          * an SVOP (and op_sv is the GV for the filehandle argument).
3328          */
3329         return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
3330 #ifdef USE_ITHREADS
3331                 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
3332 #else
3333                 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
3334 #endif
3335     case OA_LOOPEXOP:
3336         /*
3337          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
3338          * label was omitted (in which case it's a BASEOP) or else a term was
3339          * seen. In this last case, all except goto are definitely PVOP but
3340          * goto is either a PVOP (with an ordinary constant label), an UNOP
3341          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
3342          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3343          * get set.
3344          */
3345         if (o->op_flags & OPf_STACKED)
3346             return OPclass_UNOP;
3347         else if (o->op_flags & OPf_SPECIAL)
3348             return OPclass_BASEOP;
3349         else
3350             return OPclass_PVOP;
3351     case OA_METHOP:
3352         return OPclass_METHOP;
3353     case OA_UNOP_AUX:
3354         return OPclass_UNOP_AUX;
3355     }
3356     Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3357          OP_NAME(o));
3358     return OPclass_BASEOP;
3359 }
3360
3361
3362
3363 STATIC CV*
3364 S_deb_curcv(pTHX_ I32 ix)
3365 {
3366     PERL_SI *si = PL_curstackinfo;
3367     for (; ix >=0; ix--) {
3368         const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3369
3370         if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3371             return cx->blk_sub.cv;
3372         else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
3373             return cx->blk_eval.cv;
3374         else if (ix == 0 && si->si_type == PERLSI_MAIN)
3375             return PL_main_cv;
3376         else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3377                && si->si_type == PERLSI_SORT)
3378         {
3379             /* fake sort sub; use CV of caller */
3380             si = si->si_prev;
3381             ix = si->si_cxix + 1;
3382         }
3383     }
3384     return NULL;
3385 }
3386
3387 void
3388 Perl_watch(pTHX_ char **addr)
3389 {
3390     PERL_ARGS_ASSERT_WATCH;
3391
3392     PL_watchaddr = addr;
3393     PL_watchok = *addr;
3394     PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
3395         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3396 }
3397
3398 /*
3399 =for apidoc debprof
3400
3401 Called to indicate that C<o> was executed, for profiling purposes under the
3402 C<-DP> command line option.
3403
3404 =cut
3405 */
3406
3407 STATIC void
3408 S_debprof(pTHX_ const OP *o)
3409 {
3410     PERL_ARGS_ASSERT_DEBPROF;
3411
3412     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
3413         return;
3414     if (!PL_profiledata)
3415         Newxz(PL_profiledata, MAXO, U32);
3416     ++PL_profiledata[o->op_type];
3417 }
3418
3419 /*
3420 =for apidoc debprofdump
3421
3422 Dumps the contents of the data collected by the C<-DP> perl command line
3423 option.
3424
3425 =cut
3426 */
3427
3428 void
3429 Perl_debprofdump(pTHX)
3430 {
3431     unsigned i;
3432     if (!PL_profiledata)
3433         return;
3434     for (i = 0; i < MAXO; i++) {
3435         if (PL_profiledata[i])
3436             PerlIO_printf(Perl_debug_log,
3437                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
3438                                        PL_op_name[i]);
3439     }
3440 }
3441
3442
3443 /*
3444  * ex: set ts=8 sts=4 sw=4 et:
3445  */