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