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