dump.c

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