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