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 ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1077             if (cSVOPo->op_sv) {
1078       STRLEN len;
1079       const char * name;
1080       SV * const tmpsv  = newSVpvs_flags("", SVs_TEMP);
1081       SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
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         }
1090 #endif
1091         break;
1092
1093     case OP_MULTIDEREF:
1094     {
1095         UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1096         UV i, count = items[-1].uv;
1097
1098         S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
1099         for (i=0; i < count;  i++)
1100             S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1101                                     "%" UVuf " => 0x%" UVxf "\n",
1102                                     i, items[i].uv);
1103         break;
1104     }
1105
1106     case OP_CONST:
1107     case OP_HINTSEVAL:
1108     case OP_METHOD_NAMED:
1109     case OP_METHOD_SUPER:
1110     case OP_METHOD_REDIR:
1111     case OP_METHOD_REDIR_SUPER:
1112 #ifndef USE_ITHREADS
1113         /* with ITHREADS, consts are stored in the pad, and the right pad
1114          * may not be active here, so skip */
1115         S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
1116                         SvPEEK(cMETHOPx_meth(o)));
1117 #endif
1118         break;
1119     case OP_NULL:
1120         if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1121             break;
1122         /* FALLTHROUGH */
1123     case OP_NEXTSTATE:
1124     case OP_DBSTATE:
1125         if (CopLINE(cCOPo))
1126             S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
1127                              (UV)CopLINE(cCOPo));
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   if (CopLABEL(cCOPo)) {
1138        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1139        STRLEN label_len;
1140        U32 label_flags;
1141        const char *label = CopLABEL_len_flags(cCOPo,
1142                                                 &label_len, &label_flags);
1143        S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1144                            generic_pv_escape( tmpsv, label, label_len,
1145                                       (label_flags & SVf_UTF8)));
1146    }
1147         S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
1148                          (unsigned int)cCOPo->cop_seq);
1149         break;
1150
1151     case OP_ENTERITER:
1152     case OP_ENTERLOOP:
1153         S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
1154         S_opdump_link(aTHX_ cLOOPo->op_redoop, file);
1155         S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
1156         S_opdump_link(aTHX_ cLOOPo->op_nextop, file);
1157         S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
1158         S_opdump_link(aTHX_ cLOOPo->op_lastop, file);
1159         break;
1160
1161     case OP_REGCOMP:
1162     case OP_SUBSTCONT:
1163     case OP_COND_EXPR:
1164     case OP_RANGE:
1165     case OP_MAPWHILE:
1166     case OP_GREPWHILE:
1167     case OP_OR:
1168     case OP_DOR:
1169     case OP_AND:
1170     case OP_ORASSIGN:
1171     case OP_DORASSIGN:
1172     case OP_ANDASSIGN:
1173     case OP_ARGDEFELEM:
1174     case OP_ENTERGIVEN:
1175     case OP_ENTERWHEN:
1176     case OP_ENTERTRY:
1177     case OP_ONCE:
1178         S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
1179         S_opdump_link(aTHX_ cLOGOPo->op_other, file);
1180         break;
1181     case OP_SPLIT:
1182     case OP_MATCH:
1183     case OP_QR:
1184     case OP_SUBST:
1185         S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
1186         break;
1187     case OP_LEAVE:
1188     case OP_LEAVEEVAL:
1189     case OP_LEAVESUB:
1190     case OP_LEAVESUBLV:
1191     case OP_LEAVEWRITE:
1192     case OP_SCOPE:
1193         if (o->op_private & OPpREFCOUNTED)
1194             S_opdump_indent(aTHX_ o, level, bar, file,
1195                             "REFCNT = %" UVuf "\n", (UV)o->op_targ);
1196         break;
1197     default:
1198         break;
1199     }
1200     if (o->op_flags & OPf_KIDS) {
1201         OP *kid;
1202         level++;
1203         bar <<= 1;
1204         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1205             S_do_op_dump_bar(aTHX_ level,
1206                             (bar | cBOOL(OpHAS_SIBLING(kid))),
1207                             file, kid);
1208     }
1209 }
1210
1211
1212 void
1213 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1214 {
1215     S_do_op_dump_bar(aTHX_ level, 0, file, o);
1216 }
1217
1218
1219 /*
1220 =for apidoc op_dump
1221
1222 Dumps the optree starting at OP C<o> to C<STDERR>.
1223
1224 =cut
1225 */
1226
1227 void
1228 Perl_op_dump(pTHX_ const OP *o)
1229 {
1230     PERL_ARGS_ASSERT_OP_DUMP;
1231     do_op_dump(0, Perl_debug_log, o);
1232 }
1233
1234 void
1235 Perl_gv_dump(pTHX_ GV *gv)
1236 {
1237     STRLEN len;
1238     const char* name;
1239     SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1240
1241     if (!gv) {
1242         PerlIO_printf(Perl_debug_log, "{}\n");
1243         return;
1244     }
1245     sv = sv_newmortal();
1246     PerlIO_printf(Perl_debug_log, "{\n");
1247     gv_fullname3(sv, gv, NULL);
1248     name = SvPV_const(sv, len);
1249     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1250                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1251     if (gv != GvEGV(gv)) {
1252         gv_efullname3(sv, GvEGV(gv), NULL);
1253         name = SvPV_const(sv, len);
1254         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1255                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1256     }
1257     (void)PerlIO_putc(Perl_debug_log, '\n');
1258     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1259 }
1260
1261
1262 /* map magic types to the symbolic names
1263  * (with the PERL_MAGIC_ prefixed stripped)
1264  */
1265
1266 static const struct { const char type; const char *name; } magic_names[] = {
1267 #include "mg_names.inc"
1268         /* this null string terminates the list */
1269         { 0,                         NULL },
1270 };
1271
1272 void
1273 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1274 {
1275     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1276
1277     for (; mg; mg = mg->mg_moremagic) {
1278         Perl_dump_indent(aTHX_ level, file,
1279                          "  MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
1280         if (mg->mg_virtual) {
1281             const MGVTBL * const v = mg->mg_virtual;
1282             if (v >= PL_magic_vtables
1283                 && v < PL_magic_vtables + magic_vtable_max) {
1284                 const U32 i = v - PL_magic_vtables;
1285                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1286             }
1287             else
1288                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"
1289                                        UVxf "\n", PTR2UV(v));
1290         }
1291         else
1292             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1293
1294         if (mg->mg_private)
1295             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1296
1297         {
1298             int n;
1299             const char *name = NULL;
1300             for (n = 0; magic_names[n].name; n++) {
1301                 if (mg->mg_type == magic_names[n].type) {
1302                     name = magic_names[n].name;
1303                     break;
1304                 }
1305             }
1306             if (name)
1307                 Perl_dump_indent(aTHX_ level, file,
1308                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1309             else
1310                 Perl_dump_indent(aTHX_ level, file,
1311                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1312         }
1313
1314         if (mg->mg_flags) {
1315             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1316             if (mg->mg_type == PERL_MAGIC_envelem &&
1317                 mg->mg_flags & MGf_TAINTEDDIR)
1318                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1319             if (mg->mg_type == PERL_MAGIC_regex_global &&
1320                 mg->mg_flags & MGf_MINMATCH)
1321                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1322             if (mg->mg_flags & MGf_REFCOUNTED)
1323                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1324             if (mg->mg_flags & MGf_GSKIP)
1325                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1326             if (mg->mg_flags & MGf_COPY)
1327                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1328             if (mg->mg_flags & MGf_DUP)
1329                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1330             if (mg->mg_flags & MGf_LOCAL)
1331                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1332             if (mg->mg_type == PERL_MAGIC_regex_global &&
1333                 mg->mg_flags & MGf_BYTES)
1334                 Perl_dump_indent(aTHX_ level, file, "      BYTES\n");
1335         }
1336         if (mg->mg_obj) {
1337             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%" UVxf "\n",
1338                 PTR2UV(mg->mg_obj));
1339             if (mg->mg_type == PERL_MAGIC_qr) {
1340                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1341                 SV * const dsv = sv_newmortal();
1342                 const char * const s
1343                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1344                     60, NULL, NULL,
1345                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1346                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1347                 );
1348                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1349                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %" IVdf "\n",
1350                         (IV)RX_REFCNT(re));
1351             }
1352             if (mg->mg_flags & MGf_REFCOUNTED)
1353                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1354         }
1355         if (mg->mg_len)
1356             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1357         if (mg->mg_ptr) {
1358             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
1359             if (mg->mg_len >= 0) {
1360                 if (mg->mg_type != PERL_MAGIC_utf8) {
1361                     SV * const sv = newSVpvs("");
1362                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1363                     SvREFCNT_dec_NN(sv);
1364                 }
1365             }
1366             else if (mg->mg_len == HEf_SVKEY) {
1367                 PerlIO_puts(file, " => HEf_SVKEY\n");
1368                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1369                            maxnest, dumpops, pvlim); /* MG is already +1 */
1370                 continue;
1371             }
1372             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1373             else
1374                 PerlIO_puts(
1375                   file,
1376                  " ???? - " __FILE__
1377                  " does not know how to handle this MG_LEN"
1378                 );
1379             (void)PerlIO_putc(file, '\n');
1380         }
1381         if (mg->mg_type == PERL_MAGIC_utf8) {
1382             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1383             if (cache) {
1384                 IV i;
1385                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1386                     Perl_dump_indent(aTHX_ level, file,
1387                                      "      %2" IVdf ": %" UVuf " -> %" UVuf "\n",
1388                                      i,
1389                                      (UV)cache[i * 2],
1390                                      (UV)cache[i * 2 + 1]);
1391             }
1392         }
1393     }
1394 }
1395
1396 void
1397 Perl_magic_dump(pTHX_ const MAGIC *mg)
1398 {
1399     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1400 }
1401
1402 void
1403 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1404 {
1405     const char *hvname;
1406
1407     PERL_ARGS_ASSERT_DO_HV_DUMP;
1408
1409     Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1410     if (sv && (hvname = HvNAME_get(sv)))
1411     {
1412         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1413            name which quite legally could contain insane things like tabs, newlines, nulls or
1414            other scary crap - this should produce sane results - except maybe for unicode package
1415            names - but we will wait for someone to file a bug on that - demerphq */
1416         SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1417         PerlIO_printf(file, "\t\"%s\"\n",
1418                               generic_pv_escape( tmpsv, hvname,
1419                                    HvNAMELEN(sv), HvNAMEUTF8(sv)));
1420     }
1421     else
1422         (void)PerlIO_putc(file, '\n');
1423 }
1424
1425 void
1426 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1427 {
1428     PERL_ARGS_ASSERT_DO_GV_DUMP;
1429
1430     Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1431     if (sv && GvNAME(sv)) {
1432         SV * const tmpsv = newSVpvs("");
1433         PerlIO_printf(file, "\t\"%s\"\n",
1434                               generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1435     }
1436     else
1437         (void)PerlIO_putc(file, '\n');
1438 }
1439
1440 void
1441 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1442 {
1443     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1444
1445     Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
1446     if (sv && GvNAME(sv)) {
1447        SV *tmp = newSVpvs_flags("", SVs_TEMP);
1448         const char *hvname;
1449         HV * const stash = GvSTASH(sv);
1450         PerlIO_printf(file, "\t");
1451    /* TODO might have an extra \" here */
1452         if (stash && (hvname = HvNAME_get(stash))) {
1453             PerlIO_printf(file, "\"%s\" :: \"",
1454                                   generic_pv_escape(tmp, hvname,
1455                                       HvNAMELEN(stash), HvNAMEUTF8(stash)));
1456         }
1457         PerlIO_printf(file, "%s\"\n",
1458                               generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1459     }
1460     else
1461         (void)PerlIO_putc(file, '\n');
1462 }
1463
1464 const struct flag_to_name first_sv_flags_names[] = {
1465     {SVs_TEMP, "TEMP,"},
1466     {SVs_OBJECT, "OBJECT,"},
1467     {SVs_GMG, "GMG,"},
1468     {SVs_SMG, "SMG,"},
1469     {SVs_RMG, "RMG,"},
1470     {SVf_IOK, "IOK,"},
1471     {SVf_NOK, "NOK,"},
1472     {SVf_POK, "POK,"}
1473 };
1474
1475 const struct flag_to_name second_sv_flags_names[] = {
1476     {SVf_OOK, "OOK,"},
1477     {SVf_FAKE, "FAKE,"},
1478     {SVf_READONLY, "READONLY,"},
1479     {SVf_PROTECT, "PROTECT,"},
1480     {SVf_BREAK, "BREAK,"},
1481     {SVp_IOK, "pIOK,"},
1482     {SVp_NOK, "pNOK,"},
1483     {SVp_POK, "pPOK,"}
1484 };
1485
1486 const struct flag_to_name cv_flags_names[] = {
1487     {CVf_ANON, "ANON,"},
1488     {CVf_UNIQUE, "UNIQUE,"},
1489     {CVf_CLONE, "CLONE,"},
1490     {CVf_CLONED, "CLONED,"},
1491     {CVf_CONST, "CONST,"},
1492     {CVf_NODEBUG, "NODEBUG,"},
1493     {CVf_LVALUE, "LVALUE,"},
1494     {CVf_METHOD, "METHOD,"},
1495     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1496     {CVf_CVGV_RC, "CVGV_RC,"},
1497     {CVf_DYNFILE, "DYNFILE,"},
1498     {CVf_AUTOLOAD, "AUTOLOAD,"},
1499     {CVf_HASEVAL, "HASEVAL,"},
1500     {CVf_SLABBED, "SLABBED,"},
1501     {CVf_NAMED, "NAMED,"},
1502     {CVf_LEXICAL, "LEXICAL,"},
1503     {CVf_ISXSUB, "ISXSUB,"}
1504 };
1505
1506 const struct flag_to_name hv_flags_names[] = {
1507     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1508     {SVphv_LAZYDEL, "LAZYDEL,"},
1509     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1510     {SVf_AMAGIC, "OVERLOAD,"},
1511     {SVphv_CLONEABLE, "CLONEABLE,"}
1512 };
1513
1514 const struct flag_to_name gp_flags_names[] = {
1515     {GVf_INTRO, "INTRO,"},
1516     {GVf_MULTI, "MULTI,"},
1517     {GVf_ASSUMECV, "ASSUMECV,"},
1518 };
1519
1520 const struct flag_to_name gp_flags_imported_names[] = {
1521     {GVf_IMPORTED_SV, " SV"},
1522     {GVf_IMPORTED_AV, " AV"},
1523     {GVf_IMPORTED_HV, " HV"},
1524     {GVf_IMPORTED_CV, " CV"},
1525 };
1526
1527 /* NOTE: this structure is mostly duplicative of one generated by
1528  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1529  * the two. - Yves */
1530 const struct flag_to_name regexp_extflags_names[] = {
1531     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1532     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1533     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1534     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1535     {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1536     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1537     {RXf_PMf_NOCAPTURE,   "PMf_NOCAPURE,"},
1538     {RXf_IS_ANCHORED,     "IS_ANCHORED,"},
1539     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1540     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1541     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1542     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1543     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1544     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1545     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1546     {RXf_SPLIT,           "SPLIT,"},
1547     {RXf_COPY_DONE,       "COPY_DONE,"},
1548     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1549     {RXf_TAINTED,         "TAINTED,"},
1550     {RXf_START_ONLY,      "START_ONLY,"},
1551     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1552     {RXf_WHITE,           "WHITE,"},
1553     {RXf_NULL,            "NULL,"},
1554 };
1555
1556 /* NOTE: this structure is mostly duplicative of one generated by
1557  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1558  * the two. - Yves */
1559 const struct flag_to_name regexp_core_intflags_names[] = {
1560     {PREGf_SKIP,            "SKIP,"},
1561     {PREGf_IMPLICIT,        "IMPLICIT,"},
1562     {PREGf_NAUGHTY,         "NAUGHTY,"},
1563     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1564     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1565     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1566     {PREGf_NOSCAN,          "NOSCAN,"},
1567     {PREGf_GPOS_SEEN,       "GPOS_SEEN,"},
1568     {PREGf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1569     {PREGf_ANCH_MBOL,       "ANCH_MBOL,"},
1570     {PREGf_ANCH_SBOL,       "ANCH_SBOL,"},
1571     {PREGf_ANCH_GPOS,       "ANCH_GPOS,"},
1572 };
1573
1574 /* Perl_do_sv_dump():
1575  *
1576  * level:   amount to indent the output
1577  * sv:      the object to dump
1578  * nest:    the current level of recursion
1579  * maxnest: the maximum allowed level of recursion
1580  * dumpops: if true, also dump the ops associated with a CV
1581  * pvlim:   limit on the length of any strings that are output
1582  * */
1583
1584 void
1585 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1586 {
1587     SV *d;
1588     const char *s;
1589     U32 flags;
1590     U32 type;
1591
1592     PERL_ARGS_ASSERT_DO_SV_DUMP;
1593
1594     if (!sv) {
1595         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1596         return;
1597     }
1598
1599     flags = SvFLAGS(sv);
1600     type = SvTYPE(sv);
1601
1602     /* process general SV flags */
1603
1604     d = Perl_newSVpvf(aTHX_
1605                    "(0x%" UVxf ") at 0x%" UVxf "\n%*s  REFCNT = %" IVdf "\n%*s  FLAGS = (",
1606                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1607                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1608                    (int)(PL_dumpindent*level), "");
1609
1610     if ((flags & SVs_PADSTALE))
1611             sv_catpv(d, "PADSTALE,");
1612     if ((flags & SVs_PADTMP))
1613             sv_catpv(d, "PADTMP,");
1614     append_flags(d, flags, first_sv_flags_names);
1615     if (flags & SVf_ROK)  {
1616                                 sv_catpv(d, "ROK,");
1617         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1618     }
1619     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1620     append_flags(d, flags, second_sv_flags_names);
1621     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1622                            && type != SVt_PVAV) {
1623         if (SvPCS_IMPORTED(sv))
1624                                 sv_catpv(d, "PCS_IMPORTED,");
1625         else
1626                                 sv_catpv(d, "SCREAM,");
1627     }
1628
1629     /* process type-specific SV flags */
1630
1631     switch (type) {
1632     case SVt_PVCV:
1633     case SVt_PVFM:
1634         append_flags(d, CvFLAGS(sv), cv_flags_names);
1635         break;
1636     case SVt_PVHV:
1637         append_flags(d, flags, hv_flags_names);
1638         break;
1639     case SVt_PVGV:
1640     case SVt_PVLV:
1641         if (isGV_with_GP(sv)) {
1642             append_flags(d, GvFLAGS(sv), gp_flags_names);
1643         }
1644         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1645             sv_catpv(d, "IMPORT");
1646             if (GvIMPORTED(sv) == GVf_IMPORTED)
1647                 sv_catpv(d, "ALL,");
1648             else {
1649                 sv_catpv(d, "(");
1650                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1651                 sv_catpv(d, " ),");
1652             }
1653         }
1654         /* FALLTHROUGH */
1655     case SVt_PVMG:
1656     default:
1657         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1658         break;
1659
1660     case SVt_PVAV:
1661         break;
1662     }
1663     /* SVphv_SHAREKEYS is also 0x20000000 */
1664     if ((type != SVt_PVHV) && SvUTF8(sv))
1665         sv_catpv(d, "UTF8");
1666
1667     if (*(SvEND(d) - 1) == ',') {
1668         SvCUR_set(d, SvCUR(d) - 1);
1669         SvPVX(d)[SvCUR(d)] = '\0';
1670     }
1671     sv_catpv(d, ")");
1672     s = SvPVX_const(d);
1673
1674     /* dump initial SV details */
1675
1676 #ifdef DEBUG_LEAKING_SCALARS
1677     Perl_dump_indent(aTHX_ level, file,
1678         "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1679         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1680         sv->sv_debug_line,
1681         sv->sv_debug_inpad ? "for" : "by",
1682         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1683         PTR2UV(sv->sv_debug_parent),
1684         sv->sv_debug_serial
1685     );
1686 #endif
1687     Perl_dump_indent(aTHX_ level, file, "SV = ");
1688
1689     /* Dump SV type */
1690
1691     if (type < SVt_LAST) {
1692         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1693
1694         if (type ==  SVt_NULL) {
1695             SvREFCNT_dec_NN(d);
1696             return;
1697         }
1698     } else {
1699         PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1700         SvREFCNT_dec_NN(d);
1701         return;
1702     }
1703
1704     /* Dump general SV fields */
1705
1706     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1707          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1708          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1709         || (type == SVt_IV && !SvROK(sv))) {
1710         if (SvIsUV(sv)
1711                                      )
1712             Perl_dump_indent(aTHX_ level, file, "  UV = %" UVuf, (UV)SvUVX(sv));
1713         else
1714             Perl_dump_indent(aTHX_ level, file, "  IV = %" IVdf, (IV)SvIVX(sv));
1715         (void)PerlIO_putc(file, '\n');
1716     }
1717
1718     if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1719                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1720                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1721                || type == SVt_NV) {
1722         STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1723         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1724         RESTORE_LC_NUMERIC_UNDERLYING();
1725     }
1726
1727     if (SvROK(sv)) {
1728         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%" UVxf "\n",
1729                                PTR2UV(SvRV(sv)));
1730         if (nest < maxnest)
1731             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1732     }
1733
1734     if (type < SVt_PV) {
1735         SvREFCNT_dec_NN(d);
1736         return;
1737     }
1738
1739     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1740      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1741         const bool re = isREGEXP(sv);
1742         const char * const ptr =
1743             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1744         if (ptr) {
1745             STRLEN delta;
1746             if (SvOOK(sv)) {
1747                 SvOOK_offset(sv, delta);
1748                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %" UVuf "\n",
1749                                  (UV) delta);
1750             } else {
1751                 delta = 0;
1752             }
1753             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%" UVxf " ",
1754                                    PTR2UV(ptr));
1755             if (SvOOK(sv)) {
1756                 PerlIO_printf(file, "( %s . ) ",
1757                               pv_display(d, ptr - delta, delta, 0,
1758                                          pvlim));
1759             }
1760             if (type == SVt_INVLIST) {
1761                 PerlIO_printf(file, "\n");
1762                 /* 4 blanks indents 2 beyond the PV, etc */
1763                 _invlist_dump(file, level, "    ", sv);
1764             }
1765             else {
1766                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1767                                                      re ? 0 : SvLEN(sv),
1768                                                      pvlim));
1769                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1770                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1771                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1772                                                         UNI_DISPLAY_QQ));
1773                 PerlIO_printf(file, "\n");
1774             }
1775             Perl_dump_indent(aTHX_ level, file, "  CUR = %" IVdf "\n", (IV)SvCUR(sv));
1776             if (!re)
1777                 Perl_dump_indent(aTHX_ level, file, "  LEN = %" IVdf "\n",
1778                                        (IV)SvLEN(sv));
1779 #ifdef PERL_COPY_ON_WRITE
1780             if (SvIsCOW(sv) && SvLEN(sv))
1781                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1782                                        CowREFCNT(sv));
1783 #endif
1784         }
1785         else
1786             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1787     }
1788
1789     if (type >= SVt_PVMG) {
1790         if (SvMAGIC(sv))
1791                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1792         if (SvSTASH(sv))
1793             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1794
1795         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1796             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %" IVdf "\n",
1797                                    (IV)BmUSEFUL(sv));
1798         }
1799     }
1800
1801     /* Dump type-specific SV fields */
1802
1803     switch (type) {
1804     case SVt_PVAV:
1805         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf,
1806                                PTR2UV(AvARRAY(sv)));
1807         if (AvARRAY(sv) != AvALLOC(sv)) {
1808             PerlIO_printf(file, " (offset=%" IVdf ")\n",
1809                                 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1810             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%" UVxf "\n",
1811                                    PTR2UV(AvALLOC(sv)));
1812         }
1813         else
1814             (void)PerlIO_putc(file, '\n');
1815         Perl_dump_indent(aTHX_ level, file, "  FILL = %" IVdf "\n",
1816                                (IV)AvFILLp(sv));
1817         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
1818                                (IV)AvMAX(sv));
1819         SvPVCLEAR(d);
1820         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1821         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1822         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1823                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1824         if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1825             SSize_t count;
1826             SV **svp = AvARRAY(MUTABLE_AV(sv));
1827             for (count = 0;
1828                  count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1829                  count++, svp++)
1830             {
1831                 SV* const elt = *svp;
1832                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1833                                        (IV)count);
1834                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1835             }
1836         }
1837         break;
1838     case SVt_PVHV: {
1839         U32 usedkeys;
1840         if (SvOOK(sv)) {
1841             struct xpvhv_aux *const aux = HvAUX(sv);
1842             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %" UVuf "\n",
1843                              (UV)aux->xhv_aux_flags);
1844         }
1845         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1846         usedkeys = HvUSEDKEYS(sv);
1847         if (HvARRAY(sv) && usedkeys) {
1848             /* Show distribution of HEs in the ARRAY */
1849             int freq[200];
1850 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1851             int i;
1852             int max = 0;
1853             U32 pow2 = 2, keys = usedkeys;
1854             NV theoret, sum = 0;
1855
1856             PerlIO_printf(file, "  (");
1857             Zero(freq, FREQ_MAX + 1, int);
1858             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1859                 HE* h;
1860                 int count = 0;
1861                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1862                     count++;
1863                 if (count > FREQ_MAX)
1864                     count = FREQ_MAX;
1865                 freq[count]++;
1866                 if (max < count)
1867                     max = count;
1868             }
1869             for (i = 0; i <= max; i++) {
1870                 if (freq[i]) {
1871                     PerlIO_printf(file, "%d%s:%d", i,
1872                                   (i == FREQ_MAX) ? "+" : "",
1873                                   freq[i]);
1874                     if (i != max)
1875                         PerlIO_printf(file, ", ");
1876                 }
1877             }
1878             (void)PerlIO_putc(file, ')');
1879             /* The "quality" of a hash is defined as the total number of
1880                comparisons needed to access every element once, relative
1881                to the expected number needed for a random hash.
1882
1883                The total number of comparisons is equal to the sum of
1884                the squares of the number of entries in each bucket.
1885                For a random hash of n keys into k buckets, the expected
1886                value is
1887                                 n + n(n-1)/2k
1888             */
1889
1890             for (i = max; i > 0; i--) { /* Precision: count down. */
1891                 sum += freq[i] * i * i;
1892             }
1893             while ((keys = keys >> 1))
1894                 pow2 = pow2 << 1;
1895             theoret = usedkeys;
1896             theoret += theoret * (theoret-1)/pow2;
1897             (void)PerlIO_putc(file, '\n');
1898             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"
1899                                    NVff "%%", theoret/sum*100);
1900         }
1901         (void)PerlIO_putc(file, '\n');
1902         Perl_dump_indent(aTHX_ level, file, "  KEYS = %" IVdf "\n",
1903                                (IV)usedkeys);
1904         {
1905             STRLEN count = 0;
1906             HE **ents = HvARRAY(sv);
1907
1908             if (ents) {
1909                 HE *const *const last = ents + HvMAX(sv);
1910                 count = last + 1 - ents;
1911
1912                 do {
1913                     if (!*ents)
1914                         --count;
1915                 } while (++ents <= last);
1916             }
1917
1918             Perl_dump_indent(aTHX_ level, file, "  FILL = %" UVuf "\n",
1919                              (UV)count);
1920         }
1921         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
1922                                (IV)HvMAX(sv));
1923         if (SvOOK(sv)) {
1924             Perl_dump_indent(aTHX_ level, file, "  RITER = %" IVdf "\n",
1925                                    (IV)HvRITER_get(sv));
1926             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%" UVxf "\n",
1927                                    PTR2UV(HvEITER_get(sv)));
1928 #ifdef PERL_HASH_RANDOMIZE_KEYS
1929             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%" UVxf,
1930                                    (UV)HvRAND_get(sv));
1931             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1932                 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
1933                                     (UV)HvLASTRAND_get(sv));
1934             }
1935 #endif
1936             (void)PerlIO_putc(file, '\n');
1937         }
1938         {
1939             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1940             if (mg && mg->mg_obj) {
1941                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
1942             }
1943         }
1944         {
1945             const char * const hvname = HvNAME_get(sv);
1946             if (hvname) {
1947           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1948      Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1949                                        generic_pv_escape( tmpsv, hvname,
1950                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
1951         }
1952         }
1953         if (SvOOK(sv)) {
1954             AV * const backrefs
1955                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1956             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1957             if (HvAUX(sv)->xhv_name_count)
1958                 Perl_dump_indent(aTHX_
1959                  level, file, "  NAMECOUNT = %" IVdf "\n",
1960                  (IV)HvAUX(sv)->xhv_name_count
1961                 );
1962             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1963                 const I32 count = HvAUX(sv)->xhv_name_count;
1964                 if (count) {
1965                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1966                     /* The starting point is the first element if count is
1967                        positive and the second element if count is negative. */
1968                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1969                         + (count < 0 ? 1 : 0);
1970                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1971                         + (count < 0 ? -count : count);
1972                     while (hekp < endp) {
1973                         if (*hekp) {
1974              SV *tmp = newSVpvs_flags("", SVs_TEMP);
1975                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1976                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1977                         } else {
1978                             /* This should never happen. */
1979                             sv_catpvs(names, ", (null)");
1980                         }
1981                         ++hekp;
1982                     }
1983                     Perl_dump_indent(aTHX_
1984                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1985                     );
1986                 }
1987                 else {
1988                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1989                     const char *const hvename = HvENAME_get(sv);
1990                     Perl_dump_indent(aTHX_
1991                      level, file, "  ENAME = \"%s\"\n",
1992                      generic_pv_escape(tmp, hvename,
1993                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1994                 }
1995             }
1996             if (backrefs) {
1997                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%" UVxf "\n",
1998                                  PTR2UV(backrefs));
1999                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2000                            dumpops, pvlim);
2001             }
2002             if (meta) {
2003                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2004                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"
2005                                  UVxf ")\n",
2006                                  generic_pv_escape( tmpsv, meta->mro_which->name,
2007                                 meta->mro_which->length,
2008                                 (meta->mro_which->kflags & HVhek_UTF8)),
2009                                  PTR2UV(meta->mro_which));
2010                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"
2011                                  UVxf "\n",
2012                                  (UV)meta->cache_gen);
2013                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%" UVxf "\n",
2014                                  (UV)meta->pkg_gen);
2015                 if (meta->mro_linear_all) {
2016                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"
2017                                  UVxf "\n",
2018                                  PTR2UV(meta->mro_linear_all));
2019                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2020                            dumpops, pvlim);
2021                 }
2022                 if (meta->mro_linear_current) {
2023                     Perl_dump_indent(aTHX_ level, file,
2024                                  "  MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2025                                  PTR2UV(meta->mro_linear_current));
2026                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2027                            dumpops, pvlim);
2028                 }
2029                 if (meta->mro_nextmethod) {
2030                     Perl_dump_indent(aTHX_ level, file,
2031                                  "  MRO_NEXTMETHOD = 0x%" UVxf "\n",
2032                                  PTR2UV(meta->mro_nextmethod));
2033                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2034                            dumpops, pvlim);
2035                 }
2036                 if (meta->isa) {
2037                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%" UVxf "\n",
2038                                  PTR2UV(meta->isa));
2039                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2040                            dumpops, pvlim);
2041                 }
2042             }
2043         }
2044         if (nest < maxnest) {
2045             HV * const hv = MUTABLE_HV(sv);
2046             STRLEN i;
2047             HE *he;
2048
2049             if (HvARRAY(hv)) {
2050                 int count = maxnest - nest;
2051                 for (i=0; i <= HvMAX(hv); i++) {
2052                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2053                         U32 hash;
2054                         SV * keysv;
2055                         const char * keypv;
2056                         SV * elt;
2057                         STRLEN len;
2058
2059                         if (count-- <= 0) goto DONEHV;
2060
2061                         hash = HeHASH(he);
2062                         keysv = hv_iterkeysv(he);
2063                         keypv = SvPV_const(keysv, len);
2064                         elt = HeVAL(he);
2065
2066                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2067                         if (SvUTF8(keysv))
2068                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2069                         if (HvEITER_get(hv) == he)
2070                             PerlIO_printf(file, "[CURRENT] ");
2071                         PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
2072                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2073                     }
2074                 }
2075               DONEHV:;
2076             }
2077         }
2078         break;
2079     } /* case SVt_PVHV */
2080
2081     case SVt_PVCV:
2082         if (CvAUTOLOAD(sv)) {
2083             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2084        STRLEN len;
2085             const char *const name =  SvPV_const(sv, len);
2086             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
2087                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2088         }
2089         if (SvPOK(sv)) {
2090        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2091        const char *const proto = CvPROTO(sv);
2092             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
2093                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2094                                 SvUTF8(sv)));
2095         }
2096         /* FALLTHROUGH */
2097     case SVt_PVFM:
2098         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
2099         if (!CvISXSUB(sv)) {
2100             if (CvSTART(sv)) {
2101                 if (CvSLABBED(sv))
2102                     Perl_dump_indent(aTHX_ level, file,
2103                                  "  SLAB = 0x%" UVxf "\n",
2104                                  PTR2UV(CvSTART(sv)));
2105                 else
2106                     Perl_dump_indent(aTHX_ level, file,
2107                                  "  START = 0x%" UVxf " ===> %" IVdf "\n",
2108                                  PTR2UV(CvSTART(sv)),
2109                                  (IV)sequence_num(CvSTART(sv)));
2110             }
2111             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%" UVxf "\n",
2112                              PTR2UV(CvROOT(sv)));
2113             if (CvROOT(sv) && dumpops) {
2114                 do_op_dump(level+1, file, CvROOT(sv));
2115             }
2116         } else {
2117             SV * const constant = cv_const_sv((const CV *)sv);
2118
2119             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2120
2121             if (constant) {
2122                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%" UVxf
2123                                  " (CONST SV)\n",
2124                                  PTR2UV(CvXSUBANY(sv).any_ptr));
2125                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2126                            pvlim);
2127             } else {
2128                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %" IVdf "\n",
2129                                  (IV)CvXSUBANY(sv).any_i32);
2130             }
2131         }
2132         if (CvNAMED(sv))
2133             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2134                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
2135         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
2136         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
2137         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"
2138                                       IVdf "\n", (IV)CvDEPTH(sv));
2139         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n",
2140                                (UV)CvFLAGS(sv));
2141         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2142         if (!CvISXSUB(sv)) {
2143             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2144             if (nest < maxnest) {
2145                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2146             }
2147         }
2148         else
2149             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
2150         {
2151             const CV * const outside = CvOUTSIDE(sv);
2152             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%" UVxf " (%s)\n",
2153                         PTR2UV(outside),
2154                         (!outside ? "null"
2155                          : CvANON(outside) ? "ANON"
2156                          : (outside == PL_main_cv) ? "MAIN"
2157                          : CvUNIQUE(outside) ? "UNIQUE"
2158                          : CvGV(outside) ?
2159                              generic_pv_escape(
2160                                  newSVpvs_flags("", SVs_TEMP),
2161                                  GvNAME(CvGV(outside)),
2162                                  GvNAMELEN(CvGV(outside)),
2163                                  GvNAMEUTF8(CvGV(outside)))
2164                          : "UNDEFINED"));
2165         }
2166         if (CvOUTSIDE(sv)
2167          && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2168             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2169         break;
2170
2171     case SVt_PVGV:
2172     case SVt_PVLV:
2173         if (type == SVt_PVLV) {
2174             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2175             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2176             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2177             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2178             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2179             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2180                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2181                     dumpops, pvlim);
2182         }
2183         if (isREGEXP(sv)) goto dumpregexp;
2184         if (!isGV_with_GP(sv))
2185             break;
2186        {
2187           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2188           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2189                     generic_pv_escape(tmpsv, GvNAME(sv),
2190                                       GvNAMELEN(sv),
2191                                       GvNAMEUTF8(sv)));
2192        }
2193         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2194         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2195         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2196         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2197         if (!GvGP(sv))
2198             break;
2199         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2200         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2201         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2202         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%" UVxf "  \n", PTR2UV(GvFORM(sv)));
2203         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2204         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2205         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2206         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2207         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%" UVxf
2208                                             " (%s)\n",
2209                                (UV)GvGPFLAGS(sv),
2210                                "");
2211         Perl_dump_indent(aTHX_ level, file, "    LINE = %" IVdf "\n", (IV)GvLINE(sv));
2212         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2213         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2214         break;
2215     case SVt_PVIO:
2216         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2217         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2218         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2219         Perl_dump_indent(aTHX_ level, file, "  LINES = %" IVdf "\n", (IV)IoLINES(sv));
2220         Perl_dump_indent(aTHX_ level, file, "  PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2221         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2222         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2223         if (IoTOP_NAME(sv))
2224             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2225         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2226             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2227         else {
2228             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%" UVxf "\n",
2229                              PTR2UV(IoTOP_GV(sv)));
2230             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2231                         maxnest, dumpops, pvlim);
2232         }
2233         /* Source filters hide things that are not GVs in these three, so let's
2234            be careful out there.  */
2235         if (IoFMT_NAME(sv))
2236             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2237         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2238             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2239         else {
2240             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%" UVxf "\n",
2241                              PTR2UV(IoFMT_GV(sv)));
2242             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2243                         maxnest, dumpops, pvlim);
2244         }
2245         if (IoBOTTOM_NAME(sv))
2246             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2247         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2248             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2249         else {
2250             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%" UVxf "\n",
2251                              PTR2UV(IoBOTTOM_GV(sv)));
2252             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2253                         maxnest, dumpops, pvlim);
2254         }
2255         if (isPRINT(IoTYPE(sv)))
2256             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2257         else
2258             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2259         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2260         break;
2261     case SVt_REGEXP:
2262       dumpregexp:
2263         {
2264             struct regexp * const r = ReANY((REGEXP*)sv);
2265
2266 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2267             sv_setpv(d,"");                                 \
2268             append_flags(d, flags, names);     \
2269             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2270                 SvCUR_set(d, SvCUR(d) - 1);                 \
2271                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2272             }                                               \
2273 } STMT_END
2274             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2275             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%" UVxf " (%s)\n",
2276                                 (UV)(r->compflags), SvPVX_const(d));
2277
2278             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2279             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%" UVxf " (%s)\n",
2280                                 (UV)(r->extflags), SvPVX_const(d));
2281
2282             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%" UVxf " (%s)\n",
2283                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2284             if (r->engine == &PL_core_reg_engine) {
2285                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2286                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf " (%s)\n",
2287                                 (UV)(r->intflags), SvPVX_const(d));
2288             } else {
2289                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf "\n",
2290                                 (UV)(r->intflags));
2291             }
2292 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2293             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %" UVuf "\n",
2294                                 (UV)(r->nparens));
2295             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %" UVuf "\n",
2296                                 (UV)(r->lastparen));
2297             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %" UVuf "\n",
2298                                 (UV)(r->lastcloseparen));
2299             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %" IVdf "\n",
2300                                 (IV)(r->minlen));
2301             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %" IVdf "\n",
2302                                 (IV)(r->minlenret));
2303             Perl_dump_indent(aTHX_ level, file, "  GOFS = %" UVuf "\n",
2304                                 (UV)(r->gofs));
2305             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %" UVuf "\n",
2306                                 (UV)(r->pre_prefix));
2307             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %" IVdf "\n",
2308                                 (IV)(r->sublen));
2309             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %" IVdf "\n",
2310                                 (IV)(r->suboffset));
2311             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %" IVdf "\n",
2312                                 (IV)(r->subcoffset));
2313             if (r->subbeg)
2314                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%" UVxf " %s\n",
2315                             PTR2UV(r->subbeg),
2316                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2317             else
2318                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2319             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%" UVxf "\n",
2320                                 PTR2UV(r->mother_re));
2321             if (nest < maxnest && r->mother_re)
2322                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2323                            maxnest, dumpops, pvlim);
2324             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%" UVxf "\n",
2325                                 PTR2UV(r->paren_names));
2326             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%" UVxf "\n",
2327                                 PTR2UV(r->substrs));
2328             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%" UVxf "\n",
2329                                 PTR2UV(r->pprivate));
2330             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%" UVxf "\n",
2331                                 PTR2UV(r->offs));
2332             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%" UVxf "\n",
2333                                 PTR2UV(r->qr_anoncv));
2334 #ifdef PERL_ANY_COW
2335             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%" UVxf "\n",
2336                                 PTR2UV(r->saved_copy));
2337 #endif
2338         }
2339         break;
2340     }
2341     SvREFCNT_dec_NN(d);
2342 }
2343
2344 /*
2345 =for apidoc sv_dump
2346
2347 Dumps the contents of an SV to the C<STDERR> filehandle.
2348
2349 For an example of its output, see L<Devel::Peek>.
2350
2351 =cut
2352 */
2353
2354 void
2355 Perl_sv_dump(pTHX_ SV *sv)
2356 {
2357     PERL_ARGS_ASSERT_SV_DUMP;
2358
2359     if (SvROK(sv))
2360         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2361     else
2362         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2363 }
2364
2365 int
2366 Perl_runops_debug(pTHX)
2367 {
2368     if (!PL_op) {
2369         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2370         return 0;
2371     }
2372
2373     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2374     do {
2375 #ifdef PERL_TRACE_OPS
2376         ++PL_op_exec_cnt[PL_op->op_type];
2377 #endif
2378         if (PL_debug) {
2379             ENTER;
2380             SAVETMPS;
2381             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2382                 PerlIO_printf(Perl_debug_log,
2383                               "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2384                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2385                               PTR2UV(*PL_watchaddr));
2386             if (DEBUG_s_TEST_) {
2387                 if (DEBUG_v_TEST_) {
2388                     PerlIO_printf(Perl_debug_log, "\n");
2389                     deb_stack_all();
2390                 }
2391                 else
2392                     debstack();
2393             }
2394
2395
2396             if (DEBUG_t_TEST_) debop(PL_op);
2397             if (DEBUG_P_TEST_) debprof(PL_op);
2398             FREETMPS;
2399             LEAVE;
2400         }
2401
2402         PERL_DTRACE_PROBE_OP(PL_op);
2403     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2404     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2405     PERL_ASYNC_CHECK();
2406
2407     TAINT_NOT;
2408     return 0;
2409 }
2410
2411
2412 /* print the names of the n lexical vars starting at pad offset off */
2413
2414 STATIC void
2415 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2416 {
2417     PADNAME *sv;
2418     CV * const cv = deb_curcv(cxstack_ix);
2419     PADNAMELIST *comppad = NULL;
2420     int i;
2421
2422     if (cv) {
2423         PADLIST * const padlist = CvPADLIST(cv);
2424         comppad = PadlistNAMES(padlist);
2425     }
2426     if (paren)
2427         PerlIO_printf(Perl_debug_log, "(");
2428     for (i = 0; i < n; i++) {
2429         if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2430             PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2431         else
2432             PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2433                     (UV)(off+i));
2434         if (i < n - 1)
2435             PerlIO_printf(Perl_debug_log, ",");
2436     }
2437     if (paren)
2438         PerlIO_printf(Perl_debug_log, ")");
2439 }
2440
2441
2442 /* append to the out SV, the name of the lexical at offset off in the CV
2443  * cv */
2444
2445 static void
2446 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2447         bool paren, bool is_scalar)
2448 {
2449     PADNAME *sv;
2450     PADNAMELIST *namepad = NULL;
2451     int i;
2452
2453     if (cv) {
2454         PADLIST * const padlist = CvPADLIST(cv);
2455         namepad = PadlistNAMES(padlist);
2456     }
2457
2458     if (paren)
2459         sv_catpvs_nomg(out, "(");
2460     for (i = 0; i < n; i++) {
2461         if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2462         {
2463             STRLEN cur = SvCUR(out);
2464             Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2465                                  UTF8fARG(1, PadnameLEN(sv) - 1,
2466                                           PadnamePV(sv) + 1));
2467             if (is_scalar)
2468                 SvPVX(out)[cur] = '$';
2469         }
2470         else
2471             Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2472         if (i < n - 1)
2473             sv_catpvs_nomg(out, ",");
2474     }
2475     if (paren)
2476         sv_catpvs_nomg(out, "(");
2477 }
2478
2479
2480 static void
2481 S_append_gv_name(pTHX_ GV *gv, SV *out)
2482 {
2483     SV *sv;
2484     if (!gv) {
2485         sv_catpvs_nomg(out, "<NULLGV>");
2486         return;
2487     }
2488     sv = newSV(0);
2489     gv_fullname4(sv, gv, NULL, FALSE);
2490     Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2491     SvREFCNT_dec_NN(sv);
2492 }
2493
2494 #ifdef USE_ITHREADS
2495 #  define ITEM_SV(item) (comppad ? \
2496     *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2497 #else
2498 #  define ITEM_SV(item) UNOP_AUX_item_sv(item)
2499 #endif
2500
2501
2502 /* return a temporary SV containing a stringified representation of
2503  * the op_aux field of a MULTIDEREF op, associated with CV cv
2504  */
2505
2506 SV*
2507 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2508 {
2509     UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2510     UV actions = items->uv;
2511     SV *sv;
2512     bool last = 0;
2513     bool is_hash = FALSE;
2514     int derefs = 0;
2515     SV *out = newSVpvn_flags("",0,SVs_TEMP);
2516 #ifdef USE_ITHREADS
2517     PAD *comppad;
2518
2519     if (cv) {
2520         PADLIST *padlist = CvPADLIST(cv);
2521         comppad = PadlistARRAY(padlist)[1];
2522     }
2523     else
2524         comppad = NULL;
2525 #endif
2526
2527     PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2528
2529     while (!last) {
2530         switch (actions & MDEREF_ACTION_MASK) {
2531
2532         case MDEREF_reload:
2533             actions = (++items)->uv;
2534             continue;
2535             NOT_REACHED; /* NOTREACHED */
2536
2537         case MDEREF_HV_padhv_helem:
2538             is_hash = TRUE;
2539             /* FALLTHROUGH */
2540         case MDEREF_AV_padav_aelem:
2541             derefs = 1;
2542             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2543             goto do_elem;
2544             NOT_REACHED; /* NOTREACHED */
2545
2546         case MDEREF_HV_gvhv_helem:
2547             is_hash = TRUE;
2548             /* FALLTHROUGH */
2549         case MDEREF_AV_gvav_aelem:
2550             derefs = 1;
2551             items++;
2552             sv = ITEM_SV(items);
2553             S_append_gv_name(aTHX_ (GV*)sv, out);
2554             goto do_elem;
2555             NOT_REACHED; /* NOTREACHED */
2556
2557         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2558             is_hash = TRUE;
2559             /* FALLTHROUGH */
2560         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2561             items++;
2562             sv = ITEM_SV(items);
2563             S_append_gv_name(aTHX_ (GV*)sv, out);
2564             goto do_vivify_rv2xv_elem;
2565             NOT_REACHED; /* NOTREACHED */
2566
2567         case MDEREF_HV_padsv_vivify_rv2hv_helem:
2568             is_hash = TRUE;
2569             /* FALLTHROUGH */
2570         case MDEREF_AV_padsv_vivify_rv2av_aelem:
2571             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2572             goto do_vivify_rv2xv_elem;
2573             NOT_REACHED; /* NOTREACHED */
2574
2575         case MDEREF_HV_pop_rv2hv_helem:
2576         case MDEREF_HV_vivify_rv2hv_helem:
2577             is_hash = TRUE;
2578             /* FALLTHROUGH */
2579         do_vivify_rv2xv_elem:
2580         case MDEREF_AV_pop_rv2av_aelem:
2581         case MDEREF_AV_vivify_rv2av_aelem:
2582             if (!derefs++)
2583                 sv_catpvs_nomg(out, "->");
2584         do_elem:
2585             if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2586                 sv_catpvs_nomg(out, "->");
2587                 last = 1;
2588                 break;
2589             }
2590
2591             sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2592             switch (actions & MDEREF_INDEX_MASK) {
2593             case MDEREF_INDEX_const:
2594                 if (is_hash) {
2595                     items++;
2596                     sv = ITEM_SV(items);
2597                     if (!sv)
2598                         sv_catpvs_nomg(out, "???");
2599                     else {
2600                         STRLEN cur;
2601                         char *s;
2602                         s = SvPV(sv, cur);
2603                         pv_pretty(out, s, cur, 30,
2604                                     NULL, NULL,
2605                                     (PERL_PV_PRETTY_NOCLEAR
2606                                     |PERL_PV_PRETTY_QUOTE
2607                                     |PERL_PV_PRETTY_ELLIPSES));
2608                     }
2609                 }
2610                 else
2611                     Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2612                 break;
2613             case MDEREF_INDEX_padsv:
2614                 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2615                 break;
2616             case MDEREF_INDEX_gvsv:
2617                 items++;
2618                 sv = ITEM_SV(items);
2619                 S_append_gv_name(aTHX_ (GV*)sv, out);
2620                 break;
2621             }
2622             sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2623
2624             if (actions & MDEREF_FLAG_last)
2625                 last = 1;
2626             is_hash = FALSE;
2627
2628             break;
2629
2630         default:
2631             PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2632                 (int)(actions & MDEREF_ACTION_MASK));
2633             last = 1;
2634             break;
2635
2636         } /* switch */
2637
2638         actions >>= MDEREF_SHIFT;
2639     } /* while */
2640     return out;
2641 }
2642
2643
2644 I32
2645 Perl_debop(pTHX_ const OP *o)
2646 {
2647     PERL_ARGS_ASSERT_DEBOP;
2648
2649     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2650         return 0;
2651
2652     Perl_deb(aTHX_ "%s", OP_NAME(o));
2653     switch (o->op_type) {
2654     case OP_CONST:
2655     case OP_HINTSEVAL:
2656         /* With ITHREADS, consts are stored in the pad, and the right pad
2657          * may not be active here, so check.
2658          * Looks like only during compiling the pads are illegal.
2659          */
2660 #ifdef USE_ITHREADS
2661         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2662 #endif
2663             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2664         break;
2665     case OP_GVSV:
2666     case OP_GV:
2667         if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2668             SV * const sv = newSV(0);
2669             gv_fullname3(sv, cGVOPo_gv, NULL);
2670             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2671             SvREFCNT_dec_NN(sv);
2672         }
2673         else if (cGVOPo_gv) {
2674             SV * const sv = newSV(0);
2675             assert(SvROK(cGVOPo_gv));
2676             assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2677             PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2678                     SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2679             SvREFCNT_dec_NN(sv);
2680         }
2681         else
2682             PerlIO_printf(Perl_debug_log, "(NULL)");
2683         break;
2684
2685     case OP_PADSV:
2686     case OP_PADAV:
2687     case OP_PADHV:
2688     case OP_ARGELEM:
2689         S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2690         break;
2691
2692     case OP_PADRANGE:
2693         S_deb_padvar(aTHX_ o->op_targ,
2694                         o->op_private & OPpPADRANGE_COUNTMASK, 1);
2695         break;
2696
2697     case OP_MULTIDEREF:
2698         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2699             SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2700         break;
2701
2702     default:
2703         break;
2704     }
2705     PerlIO_printf(Perl_debug_log, "\n");
2706     return 0;
2707 }
2708
2709
2710 /*
2711 =for apidoc op_class
2712
2713 Given an op, determine what type of struct it has been allocated as.
2714 Returns one of the OPclass enums, such as OPclass_LISTOP.
2715
2716 =cut
2717 */
2718
2719
2720 OPclass
2721 Perl_op_class(pTHX_ const OP *o)
2722 {
2723     bool custom = 0;
2724
2725     if (!o)
2726         return OPclass_NULL;
2727
2728     if (o->op_type == 0) {
2729         if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2730             return OPclass_COP;
2731         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2732     }
2733
2734     if (o->op_type == OP_SASSIGN)
2735         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2736
2737     if (o->op_type == OP_AELEMFAST) {
2738 #ifdef USE_ITHREADS
2739             return OPclass_PADOP;
2740 #else
2741             return OPclass_SVOP;
2742 #endif
2743     }
2744
2745 #ifdef USE_ITHREADS
2746     if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2747         o->op_type == OP_RCATLINE)
2748         return OPclass_PADOP;
2749 #endif
2750
2751     if (o->op_type == OP_CUSTOM)
2752         custom = 1;
2753
2754     switch (OP_CLASS(o)) {
2755     case OA_BASEOP:
2756         return OPclass_BASEOP;
2757
2758     case OA_UNOP:
2759         return OPclass_UNOP;
2760
2761     case OA_BINOP:
2762         return OPclass_BINOP;
2763
2764     case OA_LOGOP:
2765         return OPclass_LOGOP;
2766
2767     case OA_LISTOP:
2768         return OPclass_LISTOP;
2769
2770     case OA_PMOP:
2771         return OPclass_PMOP;
2772
2773     case OA_SVOP:
2774         return OPclass_SVOP;
2775
2776     case OA_PADOP:
2777         return OPclass_PADOP;
2778
2779     case OA_PVOP_OR_SVOP:
2780         /*
2781          * Character translations (tr///) are usually a PVOP, keeping a
2782          * pointer to a table of shorts used to look up translations.
2783          * Under utf8, however, a simple table isn't practical; instead,
2784          * the OP is an SVOP (or, under threads, a PADOP),
2785          * and the SV is a reference to a swash
2786          * (i.e., an RV pointing to an HV).
2787          */
2788         return (!custom &&
2789                    (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2790                )
2791 #if  defined(USE_ITHREADS)
2792                 ? OPclass_PADOP : OPclass_PVOP;
2793 #else
2794                 ? OPclass_SVOP : OPclass_PVOP;
2795 #endif
2796
2797     case OA_LOOP:
2798         return OPclass_LOOP;
2799
2800     case OA_COP:
2801         return OPclass_COP;
2802
2803     case OA_BASEOP_OR_UNOP:
2804         /*
2805          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2806          * whether parens were seen. perly.y uses OPf_SPECIAL to
2807          * signal whether a BASEOP had empty parens or none.
2808          * Some other UNOPs are created later, though, so the best
2809          * test is OPf_KIDS, which is set in newUNOP.
2810          */
2811         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2812
2813     case OA_FILESTATOP:
2814         /*
2815          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2816          * the OPf_REF flag to distinguish between OP types instead of the
2817          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2818          * return OPclass_UNOP so that walkoptree can find our children. If
2819          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2820          * (no argument to the operator) it's an OP; with OPf_REF set it's
2821          * an SVOP (and op_sv is the GV for the filehandle argument).
2822          */
2823         return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2824 #ifdef USE_ITHREADS
2825                 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2826 #else
2827                 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
2828 #endif
2829     case OA_LOOPEXOP:
2830         /*
2831          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
2832          * label was omitted (in which case it's a BASEOP) or else a term was
2833          * seen. In this last case, all except goto are definitely PVOP but
2834          * goto is either a PVOP (with an ordinary constant label), an UNOP
2835          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
2836          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
2837          * get set.
2838          */
2839         if (o->op_flags & OPf_STACKED)
2840             return OPclass_UNOP;
2841         else if (o->op_flags & OPf_SPECIAL)
2842             return OPclass_BASEOP;
2843         else
2844             return OPclass_PVOP;
2845     case OA_METHOP:
2846         return OPclass_METHOP;
2847     case OA_UNOP_AUX:
2848         return OPclass_UNOP_AUX;
2849     }
2850     Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
2851          OP_NAME(o));
2852     return OPclass_BASEOP;
2853 }
2854
2855
2856
2857 STATIC CV*
2858 S_deb_curcv(pTHX_ I32 ix)
2859 {
2860     PERL_SI *si = PL_curstackinfo;
2861     for (; ix >=0; ix--) {
2862         const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2863
2864         if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2865             return cx->blk_sub.cv;
2866         else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2867             return cx->blk_eval.cv;
2868         else if (ix == 0 && si->si_type == PERLSI_MAIN)
2869             return PL_main_cv;
2870         else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2871                && si->si_type == PERLSI_SORT)
2872         {
2873             /* fake sort sub; use CV of caller */
2874             si = si->si_prev;
2875             ix = si->si_cxix + 1;
2876         }
2877     }
2878     return NULL;
2879 }
2880
2881 void
2882 Perl_watch(pTHX_ char **addr)
2883 {
2884     PERL_ARGS_ASSERT_WATCH;
2885
2886     PL_watchaddr = addr;
2887     PL_watchok = *addr;
2888     PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
2889         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2890 }
2891
2892 STATIC void
2893 S_debprof(pTHX_ const OP *o)
2894 {
2895     PERL_ARGS_ASSERT_DEBPROF;
2896
2897     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2898         return;
2899     if (!PL_profiledata)
2900         Newxz(PL_profiledata, MAXO, U32);
2901     ++PL_profiledata[o->op_type];
2902 }
2903
2904 void
2905 Perl_debprofdump(pTHX)
2906 {
2907     unsigned i;
2908     if (!PL_profiledata)
2909         return;
2910     for (i = 0; i < MAXO; i++) {
2911         if (PL_profiledata[i])
2912             PerlIO_printf(Perl_debug_log,
2913                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2914                                        PL_op_name[i]);
2915     }
2916 }
2917
2918
2919 /*
2920  * ex: set ts=8 sts=4 sw=4 et:
2921  */