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