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