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