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