dump.c

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