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