dump.c

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