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