dump.c

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