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