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