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     dVAR;
1703     SV *d;
1704     const char *s;
1705     U32 flags;
1706     U32 type;
1707
1708     PERL_ARGS_ASSERT_DO_SV_DUMP;
1709
1710     if (!sv) {
1711         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1712         return;
1713     }
1714
1715     flags = SvFLAGS(sv);
1716     type = SvTYPE(sv);
1717
1718     /* process general SV flags */
1719
1720     d = Perl_newSVpvf(aTHX_
1721                    "(0x%" UVxf ") at 0x%" UVxf "\n%*s  REFCNT = %" IVdf "\n%*s  FLAGS = (",
1722                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1723                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1724                    (int)(PL_dumpindent*level), "");
1725
1726     if ((flags & SVs_PADSTALE))
1727             sv_catpvs(d, "PADSTALE,");
1728     if ((flags & SVs_PADTMP))
1729             sv_catpvs(d, "PADTMP,");
1730     append_flags(d, flags, first_sv_flags_names);
1731     if (flags & SVf_ROK)  {
1732                                 sv_catpvs(d, "ROK,");
1733         if (SvWEAKREF(sv))      sv_catpvs(d, "WEAKREF,");
1734     }
1735     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1736     append_flags(d, flags, second_sv_flags_names);
1737     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1738                            && type != SVt_PVAV) {
1739         if (SvPCS_IMPORTED(sv))
1740                                 sv_catpvs(d, "PCS_IMPORTED,");
1741         else
1742                                 sv_catpvs(d, "SCREAM,");
1743     }
1744
1745     /* process type-specific SV flags */
1746
1747     switch (type) {
1748     case SVt_PVCV:
1749     case SVt_PVFM:
1750         append_flags(d, CvFLAGS(sv), cv_flags_names);
1751         break;
1752     case SVt_PVHV:
1753         append_flags(d, flags, hv_flags_names);
1754         break;
1755     case SVt_PVGV:
1756     case SVt_PVLV:
1757         if (isGV_with_GP(sv)) {
1758             append_flags(d, GvFLAGS(sv), gp_flags_names);
1759         }
1760         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1761             sv_catpvs(d, "IMPORT");
1762             if (GvIMPORTED(sv) == GVf_IMPORTED)
1763                 sv_catpvs(d, "ALL,");
1764             else {
1765                 sv_catpvs(d, "(");
1766                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1767                 sv_catpvs(d, " ),");
1768             }
1769         }
1770         /* FALLTHROUGH */
1771     case SVt_PVMG:
1772     default:
1773         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpvs(d, "IsUV,");
1774         break;
1775
1776     case SVt_PVAV:
1777         break;
1778     }
1779     /* SVphv_SHAREKEYS is also 0x20000000 */
1780     if ((type != SVt_PVHV) && SvUTF8(sv))
1781         sv_catpvs(d, "UTF8");
1782
1783     if (*(SvEND(d) - 1) == ',') {
1784         SvCUR_set(d, SvCUR(d) - 1);
1785         SvPVX(d)[SvCUR(d)] = '\0';
1786     }
1787     sv_catpvs(d, ")");
1788     s = SvPVX_const(d);
1789
1790     /* dump initial SV details */
1791
1792 #ifdef DEBUG_LEAKING_SCALARS
1793     Perl_dump_indent(aTHX_ level, file,
1794         "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
1795         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1796         sv->sv_debug_line,
1797         sv->sv_debug_inpad ? "for" : "by",
1798         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1799         PTR2UV(sv->sv_debug_parent),
1800         sv->sv_debug_serial
1801     );
1802 #endif
1803     Perl_dump_indent(aTHX_ level, file, "SV = ");
1804
1805     /* Dump SV type */
1806
1807     if (type < SVt_LAST) {
1808         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1809
1810         if (type ==  SVt_NULL) {
1811             SvREFCNT_dec_NN(d);
1812             return;
1813         }
1814     } else {
1815         PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
1816         SvREFCNT_dec_NN(d);
1817         return;
1818     }
1819
1820     /* Dump general SV fields */
1821
1822     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1823          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1824          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1825         || (type == SVt_IV && !SvROK(sv))) {
1826         if (SvIsUV(sv)
1827                                      )
1828             Perl_dump_indent(aTHX_ level, file, "  UV = %" UVuf, (UV)SvUVX(sv));
1829         else
1830             Perl_dump_indent(aTHX_ level, file, "  IV = %" IVdf, (IV)SvIVX(sv));
1831         (void)PerlIO_putc(file, '\n');
1832     }
1833
1834     if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1835                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1836                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1837                || type == SVt_NV) {
1838         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1839         STORE_LC_NUMERIC_SET_STANDARD();
1840         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1841         RESTORE_LC_NUMERIC();
1842     }
1843
1844     if (SvROK(sv)) {
1845         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%" UVxf "\n",
1846                                PTR2UV(SvRV(sv)));
1847         if (nest < maxnest)
1848             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1849     }
1850
1851     if (type < SVt_PV) {
1852         SvREFCNT_dec_NN(d);
1853         return;
1854     }
1855
1856     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1857      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1858         const bool re = isREGEXP(sv);
1859         const char * const ptr =
1860             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1861         if (ptr) {
1862             STRLEN delta;
1863             if (SvOOK(sv)) {
1864                 SvOOK_offset(sv, delta);
1865                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %" UVuf "\n",
1866                                  (UV) delta);
1867             } else {
1868                 delta = 0;
1869             }
1870             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%" UVxf " ",
1871                                    PTR2UV(ptr));
1872             if (SvOOK(sv)) {
1873                 PerlIO_printf(file, "( %s . ) ",
1874                               pv_display(d, ptr - delta, delta, 0,
1875                                          pvlim));
1876             }
1877             if (type == SVt_INVLIST) {
1878                 PerlIO_printf(file, "\n");
1879                 /* 4 blanks indents 2 beyond the PV, etc */
1880                 _invlist_dump(file, level, "    ", sv);
1881             }
1882             else {
1883                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1884                                                      re ? 0 : SvLEN(sv),
1885                                                      pvlim));
1886                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1887                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1888                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1889                                                         UNI_DISPLAY_QQ));
1890                 PerlIO_printf(file, "\n");
1891             }
1892             Perl_dump_indent(aTHX_ level, file, "  CUR = %" IVdf "\n", (IV)SvCUR(sv));
1893             if (re && type == SVt_PVLV)
1894                 /* LV-as-REGEXP usurps len field to store pointer to
1895                  * regexp struct */
1896                 Perl_dump_indent(aTHX_ level, file, "  REGEXP = 0x%" UVxf "\n",
1897                    PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
1898             else
1899                 Perl_dump_indent(aTHX_ level, file, "  LEN = %" IVdf "\n",
1900                                        (IV)SvLEN(sv));
1901 #ifdef PERL_COPY_ON_WRITE
1902             if (SvIsCOW(sv) && SvLEN(sv))
1903                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1904                                        CowREFCNT(sv));
1905 #endif
1906         }
1907         else
1908             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1909     }
1910
1911     if (type >= SVt_PVMG) {
1912         if (SvMAGIC(sv))
1913                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1914         if (SvSTASH(sv))
1915             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1916
1917         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1918             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %" IVdf "\n",
1919                                    (IV)BmUSEFUL(sv));
1920         }
1921     }
1922
1923     /* Dump type-specific SV fields */
1924
1925     switch (type) {
1926     case SVt_PVAV:
1927         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf,
1928                                PTR2UV(AvARRAY(sv)));
1929         if (AvARRAY(sv) != AvALLOC(sv)) {
1930             PerlIO_printf(file, " (offset=%" IVdf ")\n",
1931                                 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1932             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%" UVxf "\n",
1933                                    PTR2UV(AvALLOC(sv)));
1934         }
1935         else
1936             (void)PerlIO_putc(file, '\n');
1937         Perl_dump_indent(aTHX_ level, file, "  FILL = %" IVdf "\n",
1938                                (IV)AvFILLp(sv));
1939         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
1940                                (IV)AvMAX(sv));
1941         SvPVCLEAR(d);
1942         if (AvREAL(sv)) sv_catpvs(d, ",REAL");
1943         if (AvREIFY(sv))        sv_catpvs(d, ",REIFY");
1944         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1945                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1946         if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1947             SSize_t count;
1948             SV **svp = AvARRAY(MUTABLE_AV(sv));
1949             for (count = 0;
1950                  count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1951                  count++, svp++)
1952             {
1953                 SV* const elt = *svp;
1954                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1955                                        (IV)count);
1956                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1957             }
1958         }
1959         break;
1960     case SVt_PVHV: {
1961         U32 usedkeys;
1962         if (SvOOK(sv)) {
1963             struct xpvhv_aux *const aux = HvAUX(sv);
1964             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %" UVuf "\n",
1965                              (UV)aux->xhv_aux_flags);
1966         }
1967         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1968         usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
1969         if (HvARRAY(sv) && usedkeys) {
1970             /* Show distribution of HEs in the ARRAY */
1971             int freq[200];
1972 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1973             int i;
1974             int max = 0;
1975             U32 pow2 = 2, keys = usedkeys;
1976             NV theoret, sum = 0;
1977
1978             PerlIO_printf(file, "  (");
1979             Zero(freq, FREQ_MAX + 1, int);
1980             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1981                 HE* h;
1982                 int count = 0;
1983                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1984                     count++;
1985                 if (count > FREQ_MAX)
1986                     count = FREQ_MAX;
1987                 freq[count]++;
1988                 if (max < count)
1989                     max = count;
1990             }
1991             for (i = 0; i <= max; i++) {
1992                 if (freq[i]) {
1993                     PerlIO_printf(file, "%d%s:%d", i,
1994                                   (i == FREQ_MAX) ? "+" : "",
1995                                   freq[i]);
1996                     if (i != max)
1997                         PerlIO_printf(file, ", ");
1998                 }
1999             }
2000             (void)PerlIO_putc(file, ')');
2001             /* The "quality" of a hash is defined as the total number of
2002                comparisons needed to access every element once, relative
2003                to the expected number needed for a random hash.
2004
2005                The total number of comparisons is equal to the sum of
2006                the squares of the number of entries in each bucket.
2007                For a random hash of n keys into k buckets, the expected
2008                value is
2009                                 n + n(n-1)/2k
2010             */
2011
2012             for (i = max; i > 0; i--) { /* Precision: count down. */
2013                 sum += freq[i] * i * i;
2014             }
2015             while ((keys = keys >> 1))
2016                 pow2 = pow2 << 1;
2017             theoret = usedkeys;
2018             theoret += theoret * (theoret-1)/pow2;
2019             (void)PerlIO_putc(file, '\n');
2020             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"
2021                                    NVff "%%", theoret/sum*100);
2022         }
2023         (void)PerlIO_putc(file, '\n');
2024         Perl_dump_indent(aTHX_ level, file, "  KEYS = %" IVdf "\n",
2025                                (IV)usedkeys);
2026         {
2027             STRLEN count = 0;
2028             HE **ents = HvARRAY(sv);
2029
2030             if (ents) {
2031                 HE *const *const last = ents + HvMAX(sv);
2032                 count = last + 1 - ents;
2033
2034                 do {
2035                     if (!*ents)
2036                         --count;
2037                 } while (++ents <= last);
2038             }
2039
2040             Perl_dump_indent(aTHX_ level, file, "  FILL = %" UVuf "\n",
2041                              (UV)count);
2042         }
2043         Perl_dump_indent(aTHX_ level, file, "  MAX = %" IVdf "\n",
2044                                (IV)HvMAX(sv));
2045         if (SvOOK(sv)) {
2046             Perl_dump_indent(aTHX_ level, file, "  RITER = %" IVdf "\n",
2047                                    (IV)HvRITER_get(sv));
2048             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%" UVxf "\n",
2049                                    PTR2UV(HvEITER_get(sv)));
2050 #ifdef PERL_HASH_RANDOMIZE_KEYS
2051             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%" UVxf,
2052                                    (UV)HvRAND_get(sv));
2053             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
2054                 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2055                                     (UV)HvLASTRAND_get(sv));
2056             }
2057 #endif
2058             (void)PerlIO_putc(file, '\n');
2059         }
2060         {
2061             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
2062             if (mg && mg->mg_obj) {
2063                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
2064             }
2065         }
2066         {
2067             const char * const hvname = HvNAME_get(sv);
2068             if (hvname) {
2069                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2070                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2071                                        generic_pv_escape( tmpsv, hvname,
2072                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
2073         }
2074         }
2075         if (SvOOK(sv)) {
2076             AV * const backrefs
2077                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
2078             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
2079             if (HvAUX(sv)->xhv_name_count)
2080                 Perl_dump_indent(aTHX_
2081                  level, file, "  NAMECOUNT = %" IVdf "\n",
2082                  (IV)HvAUX(sv)->xhv_name_count
2083                 );
2084             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
2085                 const I32 count = HvAUX(sv)->xhv_name_count;
2086                 if (count) {
2087                     SV * const names = newSVpvs_flags("", SVs_TEMP);
2088                     /* The starting point is the first element if count is
2089                        positive and the second element if count is negative. */
2090                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2091                         + (count < 0 ? 1 : 0);
2092                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2093                         + (count < 0 ? -count : count);
2094                     while (hekp < endp) {
2095                         if (*hekp) {
2096                             SV *tmp = newSVpvs_flags("", SVs_TEMP);
2097                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2098                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
2099                         } else {
2100                             /* This should never happen. */
2101                             sv_catpvs(names, ", (null)");
2102                         }
2103                         ++hekp;
2104                     }
2105                     Perl_dump_indent(aTHX_
2106                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
2107                     );
2108                 }
2109                 else {
2110                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2111                     const char *const hvename = HvENAME_get(sv);
2112                     Perl_dump_indent(aTHX_
2113                      level, file, "  ENAME = \"%s\"\n",
2114                      generic_pv_escape(tmp, hvename,
2115                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2116                 }
2117             }
2118             if (backrefs) {
2119                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%" UVxf "\n",
2120                                  PTR2UV(backrefs));
2121                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
2122                            dumpops, pvlim);
2123             }
2124             if (meta) {
2125                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2126                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"
2127                                  UVxf ")\n",
2128                                  generic_pv_escape( tmpsv, meta->mro_which->name,
2129                                 meta->mro_which->length,
2130                                 (meta->mro_which->kflags & HVhek_UTF8)),
2131                                  PTR2UV(meta->mro_which));
2132                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"
2133                                  UVxf "\n",
2134                                  (UV)meta->cache_gen);
2135                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%" UVxf "\n",
2136                                  (UV)meta->pkg_gen);
2137                 if (meta->mro_linear_all) {
2138                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"
2139                                  UVxf "\n",
2140                                  PTR2UV(meta->mro_linear_all));
2141                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2142                            dumpops, pvlim);
2143                 }
2144                 if (meta->mro_linear_current) {
2145                     Perl_dump_indent(aTHX_ level, file,
2146                                  "  MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
2147                                  PTR2UV(meta->mro_linear_current));
2148                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2149                            dumpops, pvlim);
2150                 }
2151                 if (meta->mro_nextmethod) {
2152                     Perl_dump_indent(aTHX_ level, file,
2153                                  "  MRO_NEXTMETHOD = 0x%" UVxf "\n",
2154                                  PTR2UV(meta->mro_nextmethod));
2155                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2156                            dumpops, pvlim);
2157                 }
2158                 if (meta->isa) {
2159                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%" UVxf "\n",
2160                                  PTR2UV(meta->isa));
2161                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2162                            dumpops, pvlim);
2163                 }
2164             }
2165         }
2166         if (nest < maxnest) {
2167             HV * const hv = MUTABLE_HV(sv);
2168             STRLEN i;
2169             HE *he;
2170
2171             if (HvARRAY(hv)) {
2172                 int count = maxnest - nest;
2173                 for (i=0; i <= HvMAX(hv); i++) {
2174                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2175                         U32 hash;
2176                         SV * keysv;
2177                         const char * keypv;
2178                         SV * elt;
2179                         STRLEN len;
2180
2181                         if (count-- <= 0) goto DONEHV;
2182
2183                         hash = HeHASH(he);
2184                         keysv = hv_iterkeysv(he);
2185                         keypv = SvPV_const(keysv, len);
2186                         elt = HeVAL(he);
2187
2188                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2189                         if (SvUTF8(keysv))
2190                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2191                         if (HvEITER_get(hv) == he)
2192                             PerlIO_printf(file, "[CURRENT] ");
2193                         PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
2194                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2195                     }
2196                 }
2197               DONEHV:;
2198             }
2199         }
2200         break;
2201     } /* case SVt_PVHV */
2202
2203     case SVt_PVCV:
2204         if (CvAUTOLOAD(sv)) {
2205             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2206             STRLEN len;
2207             const char *const name =  SvPV_const(sv, len);
2208             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
2209                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
2210         }
2211         if (SvPOK(sv)) {
2212             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2213             const char *const proto = CvPROTO(sv);
2214             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
2215                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2216                                 SvUTF8(sv)));
2217         }
2218         /* FALLTHROUGH */
2219     case SVt_PVFM:
2220         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
2221         if (!CvISXSUB(sv)) {
2222             if (CvSTART(sv)) {
2223                 if (CvSLABBED(sv))
2224                     Perl_dump_indent(aTHX_ level, file,
2225                                  "  SLAB = 0x%" UVxf "\n",
2226                                  PTR2UV(CvSTART(sv)));
2227                 else
2228                     Perl_dump_indent(aTHX_ level, file,
2229                                  "  START = 0x%" UVxf " ===> %" IVdf "\n",
2230                                  PTR2UV(CvSTART(sv)),
2231                                  (IV)sequence_num(CvSTART(sv)));
2232             }
2233             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%" UVxf "\n",
2234                              PTR2UV(CvROOT(sv)));
2235             if (CvROOT(sv) && dumpops) {
2236                 do_op_dump(level+1, file, CvROOT(sv));
2237             }
2238         } else {
2239             SV * const constant = cv_const_sv((const CV *)sv);
2240
2241             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
2242
2243             if (constant) {
2244                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%" UVxf
2245                                  " (CONST SV)\n",
2246                                  PTR2UV(CvXSUBANY(sv).any_ptr));
2247                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2248                            pvlim);
2249             } else {
2250                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %" IVdf "\n",
2251                                  (IV)CvXSUBANY(sv).any_i32);
2252             }
2253         }
2254         if (CvNAMED(sv))
2255             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2256                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
2257         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
2258         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
2259         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"
2260                                       IVdf "\n", (IV)CvDEPTH(sv));
2261         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n",
2262                                (UV)CvFLAGS(sv));
2263         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
2264         if (!CvISXSUB(sv)) {
2265             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
2266             if (nest < maxnest) {
2267                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2268             }
2269         }
2270         else
2271             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
2272         {
2273             const CV * const outside = CvOUTSIDE(sv);
2274             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%" UVxf " (%s)\n",
2275                         PTR2UV(outside),
2276                         (!outside ? "null"
2277                          : CvANON(outside) ? "ANON"
2278                          : (outside == PL_main_cv) ? "MAIN"
2279                          : CvUNIQUE(outside) ? "UNIQUE"
2280                          : CvGV(outside) ?
2281                              generic_pv_escape(
2282                                  newSVpvs_flags("", SVs_TEMP),
2283                                  GvNAME(CvGV(outside)),
2284                                  GvNAMELEN(CvGV(outside)),
2285                                  GvNAMEUTF8(CvGV(outside)))
2286                          : "UNDEFINED"));
2287         }
2288         if (CvOUTSIDE(sv)
2289          && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2290             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2291         break;
2292
2293     case SVt_PVGV:
2294     case SVt_PVLV:
2295         if (type == SVt_PVLV) {
2296             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2297             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2298             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2299             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2300             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
2301             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2302                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2303                     dumpops, pvlim);
2304         }
2305         if (isREGEXP(sv)) goto dumpregexp;
2306         if (!isGV_with_GP(sv))
2307             break;
2308         {
2309             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2310             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2311                      generic_pv_escape(tmpsv, GvNAME(sv),
2312                                        GvNAMELEN(sv),
2313                                        GvNAMEUTF8(sv)));
2314         }
2315         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
2316         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2317         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2318         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
2319         if (!GvGP(sv))
2320             break;
2321         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2322         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2323         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2324         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%" UVxf "  \n", PTR2UV(GvFORM(sv)));
2325         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2326         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2327         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2328         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2329         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%" UVxf
2330                                             " (%s)\n",
2331                                (UV)GvGPFLAGS(sv),
2332                                "");
2333         Perl_dump_indent(aTHX_ level, file, "    LINE = %" IVdf "\n", (IV)GvLINE(sv));
2334         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2335         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2336         break;
2337     case SVt_PVIO:
2338         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2339         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2340         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2341         Perl_dump_indent(aTHX_ level, file, "  LINES = %" IVdf "\n", (IV)IoLINES(sv));
2342         Perl_dump_indent(aTHX_ level, file, "  PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2343         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2344         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
2345         if (IoTOP_NAME(sv))
2346             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2347         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2348             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2349         else {
2350             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%" UVxf "\n",
2351                              PTR2UV(IoTOP_GV(sv)));
2352             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2353                         maxnest, dumpops, pvlim);
2354         }
2355         /* Source filters hide things that are not GVs in these three, so let's
2356            be careful out there.  */
2357         if (IoFMT_NAME(sv))
2358             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2359         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2360             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2361         else {
2362             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%" UVxf "\n",
2363                              PTR2UV(IoFMT_GV(sv)));
2364             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2365                         maxnest, dumpops, pvlim);
2366         }
2367         if (IoBOTTOM_NAME(sv))
2368             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2369         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2370             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2371         else {
2372             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%" UVxf "\n",
2373                              PTR2UV(IoBOTTOM_GV(sv)));
2374             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2375                         maxnest, dumpops, pvlim);
2376         }
2377         if (isPRINT(IoTYPE(sv)))
2378             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2379         else
2380             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2381         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
2382         break;
2383     case SVt_REGEXP:
2384       dumpregexp:
2385         {
2386             struct regexp * const r = ReANY((REGEXP*)sv);
2387
2388 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2389             sv_setpv(d,"");                                 \
2390             append_flags(d, flags, names);     \
2391             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2392                 SvCUR_set(d, SvCUR(d) - 1);                 \
2393                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2394             }                                               \
2395 } STMT_END
2396             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2397             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%" UVxf " (%s)\n",
2398                                 (UV)(r->compflags), SvPVX_const(d));
2399
2400             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2401             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%" UVxf " (%s)\n",
2402                                 (UV)(r->extflags), SvPVX_const(d));
2403
2404             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%" UVxf " (%s)\n",
2405                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2406             if (r->engine == &PL_core_reg_engine) {
2407                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2408                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf " (%s)\n",
2409                                 (UV)(r->intflags), SvPVX_const(d));
2410             } else {
2411                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%" UVxf "\n",
2412                                 (UV)(r->intflags));
2413             }
2414 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2415             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %" UVuf "\n",
2416                                 (UV)(r->nparens));
2417             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %" UVuf "\n",
2418                                 (UV)(r->lastparen));
2419             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %" UVuf "\n",
2420                                 (UV)(r->lastcloseparen));
2421             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %" IVdf "\n",
2422                                 (IV)(r->minlen));
2423             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %" IVdf "\n",
2424                                 (IV)(r->minlenret));
2425             Perl_dump_indent(aTHX_ level, file, "  GOFS = %" UVuf "\n",
2426                                 (UV)(r->gofs));
2427             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %" UVuf "\n",
2428                                 (UV)(r->pre_prefix));
2429             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %" IVdf "\n",
2430                                 (IV)(r->sublen));
2431             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %" IVdf "\n",
2432                                 (IV)(r->suboffset));
2433             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %" IVdf "\n",
2434                                 (IV)(r->subcoffset));
2435             if (r->subbeg)
2436                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%" UVxf " %s\n",
2437                             PTR2UV(r->subbeg),
2438                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2439             else
2440                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2441             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%" UVxf "\n",
2442                                 PTR2UV(r->mother_re));
2443             if (nest < maxnest && r->mother_re)
2444                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2445                            maxnest, dumpops, pvlim);
2446             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%" UVxf "\n",
2447                                 PTR2UV(r->paren_names));
2448             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%" UVxf "\n",
2449                                 PTR2UV(r->substrs));
2450             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%" UVxf "\n",
2451                                 PTR2UV(r->pprivate));
2452             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%" UVxf "\n",
2453                                 PTR2UV(r->offs));
2454             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%" UVxf "\n",
2455                                 PTR2UV(r->qr_anoncv));
2456 #ifdef PERL_ANY_COW
2457             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%" UVxf "\n",
2458                                 PTR2UV(r->saved_copy));
2459 #endif
2460         }
2461         break;
2462     }
2463     SvREFCNT_dec_NN(d);
2464 }
2465
2466 /*
2467 =for apidoc sv_dump
2468
2469 Dumps the contents of an SV to the C<STDERR> filehandle.
2470
2471 For an example of its output, see L<Devel::Peek>.
2472
2473 =cut
2474 */
2475
2476 void
2477 Perl_sv_dump(pTHX_ SV *sv)
2478 {
2479     if (sv && SvROK(sv))
2480         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2481     else
2482         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2483 }
2484
2485 int
2486 Perl_runops_debug(pTHX)
2487 {
2488 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2489     SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2490
2491     PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2492 #endif
2493
2494     if (!PL_op) {
2495         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2496         return 0;
2497     }
2498     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2499     do {
2500 #ifdef PERL_TRACE_OPS
2501         ++PL_op_exec_cnt[PL_op->op_type];
2502 #endif
2503 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2504         if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2505             Perl_croak_nocontext(
2506                 "panic: previous op failed to extend arg stack: "
2507                 "base=%p, sp=%p, hwm=%p\n",
2508                     PL_stack_base, PL_stack_sp,
2509                     PL_stack_base + PL_curstackinfo->si_stack_hwm);
2510         PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2511 #endif
2512         if (PL_debug) {
2513             ENTER;
2514             SAVETMPS;
2515             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2516                 PerlIO_printf(Perl_debug_log,
2517                               "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
2518                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2519                               PTR2UV(*PL_watchaddr));
2520             if (DEBUG_s_TEST_) {
2521                 if (DEBUG_v_TEST_) {
2522                     PerlIO_printf(Perl_debug_log, "\n");
2523                     deb_stack_all();
2524                 }
2525                 else
2526                     debstack();
2527             }
2528
2529
2530             if (DEBUG_t_TEST_) debop(PL_op);
2531             if (DEBUG_P_TEST_) debprof(PL_op);
2532             FREETMPS;
2533             LEAVE;
2534         }
2535
2536         PERL_DTRACE_PROBE_OP(PL_op);
2537     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2538     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2539     PERL_ASYNC_CHECK();
2540
2541 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
2542     if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2543         PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2544 #endif
2545     TAINT_NOT;
2546     return 0;
2547 }
2548
2549
2550 /* print the names of the n lexical vars starting at pad offset off */
2551
2552 STATIC void
2553 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2554 {
2555     PADNAME *sv;
2556     CV * const cv = deb_curcv(cxstack_ix);
2557     PADNAMELIST *comppad = NULL;
2558     int i;
2559
2560     if (cv) {
2561         PADLIST * const padlist = CvPADLIST(cv);
2562         comppad = PadlistNAMES(padlist);
2563     }
2564     if (paren)
2565         PerlIO_printf(Perl_debug_log, "(");
2566     for (i = 0; i < n; i++) {
2567         if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2568             PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
2569         else
2570             PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
2571                     (UV)(off+i));
2572         if (i < n - 1)
2573             PerlIO_printf(Perl_debug_log, ",");
2574     }
2575     if (paren)
2576         PerlIO_printf(Perl_debug_log, ")");
2577 }
2578
2579
2580 /* append to the out SV, the name of the lexical at offset off in the CV
2581  * cv */
2582
2583 static void
2584 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2585         bool paren, bool is_scalar)
2586 {
2587     PADNAME *sv;
2588     PADNAMELIST *namepad = NULL;
2589     int i;
2590
2591     if (cv) {
2592         PADLIST * const padlist = CvPADLIST(cv);
2593         namepad = PadlistNAMES(padlist);
2594     }
2595
2596     if (paren)
2597         sv_catpvs_nomg(out, "(");
2598     for (i = 0; i < n; i++) {
2599         if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2600         {
2601             STRLEN cur = SvCUR(out);
2602             Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
2603                                  UTF8fARG(1, PadnameLEN(sv) - 1,
2604                                           PadnamePV(sv) + 1));
2605             if (is_scalar)
2606                 SvPVX(out)[cur] = '$';
2607         }
2608         else
2609             Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
2610         if (i < n - 1)
2611             sv_catpvs_nomg(out, ",");
2612     }
2613     if (paren)
2614         sv_catpvs_nomg(out, "(");
2615 }
2616
2617
2618 static void
2619 S_append_gv_name(pTHX_ GV *gv, SV *out)
2620 {
2621     SV *sv;
2622     if (!gv) {
2623         sv_catpvs_nomg(out, "<NULLGV>");
2624         return;
2625     }
2626     sv = newSV(0);
2627     gv_fullname4(sv, gv, NULL, FALSE);
2628     Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
2629     SvREFCNT_dec_NN(sv);
2630 }
2631
2632 #ifdef USE_ITHREADS
2633 #  define ITEM_SV(item) (comppad ? \
2634     *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2635 #else
2636 #  define ITEM_SV(item) UNOP_AUX_item_sv(item)
2637 #endif
2638
2639
2640 /* return a temporary SV containing a stringified representation of
2641  * the op_aux field of a MULTIDEREF op, associated with CV cv
2642  */
2643
2644 SV*
2645 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2646 {
2647     UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2648     UV actions = items->uv;
2649     SV *sv;
2650     bool last = 0;
2651     bool is_hash = FALSE;
2652     int derefs = 0;
2653     SV *out = newSVpvn_flags("",0,SVs_TEMP);
2654 #ifdef USE_ITHREADS
2655     PAD *comppad;
2656
2657     if (cv) {
2658         PADLIST *padlist = CvPADLIST(cv);
2659         comppad = PadlistARRAY(padlist)[1];
2660     }
2661     else
2662         comppad = NULL;
2663 #endif
2664
2665     PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2666
2667     while (!last) {
2668         switch (actions & MDEREF_ACTION_MASK) {
2669
2670         case MDEREF_reload:
2671             actions = (++items)->uv;
2672             continue;
2673             NOT_REACHED; /* NOTREACHED */
2674
2675         case MDEREF_HV_padhv_helem:
2676             is_hash = TRUE;
2677             /* FALLTHROUGH */
2678         case MDEREF_AV_padav_aelem:
2679             derefs = 1;
2680             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2681             goto do_elem;
2682             NOT_REACHED; /* NOTREACHED */
2683
2684         case MDEREF_HV_gvhv_helem:
2685             is_hash = TRUE;
2686             /* FALLTHROUGH */
2687         case MDEREF_AV_gvav_aelem:
2688             derefs = 1;
2689             items++;
2690             sv = ITEM_SV(items);
2691             S_append_gv_name(aTHX_ (GV*)sv, out);
2692             goto do_elem;
2693             NOT_REACHED; /* NOTREACHED */
2694
2695         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2696             is_hash = TRUE;
2697             /* FALLTHROUGH */
2698         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2699             items++;
2700             sv = ITEM_SV(items);
2701             S_append_gv_name(aTHX_ (GV*)sv, out);
2702             goto do_vivify_rv2xv_elem;
2703             NOT_REACHED; /* NOTREACHED */
2704
2705         case MDEREF_HV_padsv_vivify_rv2hv_helem:
2706             is_hash = TRUE;
2707             /* FALLTHROUGH */
2708         case MDEREF_AV_padsv_vivify_rv2av_aelem:
2709             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2710             goto do_vivify_rv2xv_elem;
2711             NOT_REACHED; /* NOTREACHED */
2712
2713         case MDEREF_HV_pop_rv2hv_helem:
2714         case MDEREF_HV_vivify_rv2hv_helem:
2715             is_hash = TRUE;
2716             /* FALLTHROUGH */
2717         do_vivify_rv2xv_elem:
2718         case MDEREF_AV_pop_rv2av_aelem:
2719         case MDEREF_AV_vivify_rv2av_aelem:
2720             if (!derefs++)
2721                 sv_catpvs_nomg(out, "->");
2722         do_elem:
2723             if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2724                 sv_catpvs_nomg(out, "->");
2725                 last = 1;
2726                 break;
2727             }
2728
2729             sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2730             switch (actions & MDEREF_INDEX_MASK) {
2731             case MDEREF_INDEX_const:
2732                 if (is_hash) {
2733                     items++;
2734                     sv = ITEM_SV(items);
2735                     if (!sv)
2736                         sv_catpvs_nomg(out, "???");
2737                     else {
2738                         STRLEN cur;
2739                         char *s;
2740                         s = SvPV(sv, cur);
2741                         pv_pretty(out, s, cur, 30,
2742                                     NULL, NULL,
2743                                     (PERL_PV_PRETTY_NOCLEAR
2744                                     |PERL_PV_PRETTY_QUOTE
2745                                     |PERL_PV_PRETTY_ELLIPSES));
2746                     }
2747                 }
2748                 else
2749                     Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
2750                 break;
2751             case MDEREF_INDEX_padsv:
2752                 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2753                 break;
2754             case MDEREF_INDEX_gvsv:
2755                 items++;
2756                 sv = ITEM_SV(items);
2757                 S_append_gv_name(aTHX_ (GV*)sv, out);
2758                 break;
2759             }
2760             sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2761
2762             if (actions & MDEREF_FLAG_last)
2763                 last = 1;
2764             is_hash = FALSE;
2765
2766             break;
2767
2768         default:
2769             PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2770                 (int)(actions & MDEREF_ACTION_MASK));
2771             last = 1;
2772             break;
2773
2774         } /* switch */
2775
2776         actions >>= MDEREF_SHIFT;
2777     } /* while */
2778     return out;
2779 }
2780
2781
2782 /* Return a temporary SV containing a stringified representation of
2783  * the op_aux field of a MULTICONCAT op. Note that if the aux contains
2784  * both plain and utf8 versions of the const string and indices, only
2785  * the first is displayed.
2786  */
2787
2788 SV*
2789 Perl_multiconcat_stringify(pTHX_ const OP *o)
2790 {
2791     UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
2792     UNOP_AUX_item *lens;
2793     STRLEN len;
2794     SSize_t nargs;
2795     char *s;
2796     SV *out = newSVpvn_flags("", 0, SVs_TEMP);
2797
2798     PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
2799
2800     nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
2801     s   = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
2802     len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
2803     if (!s) {
2804         s   = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
2805         len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
2806         sv_catpvs(out, "UTF8 ");
2807     }
2808     pv_pretty(out, s, len, 50,
2809                 NULL, NULL,
2810                 (PERL_PV_PRETTY_NOCLEAR
2811                 |PERL_PV_PRETTY_QUOTE
2812                 |PERL_PV_PRETTY_ELLIPSES));
2813
2814     lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
2815     while (nargs-- >= 0) {
2816         Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
2817         lens++;
2818     }
2819     return out;
2820 }
2821
2822
2823 I32
2824 Perl_debop(pTHX_ const OP *o)
2825 {
2826     PERL_ARGS_ASSERT_DEBOP;
2827
2828     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2829         return 0;
2830
2831     Perl_deb(aTHX_ "%s", OP_NAME(o));
2832     switch (o->op_type) {
2833     case OP_CONST:
2834     case OP_HINTSEVAL:
2835         /* With ITHREADS, consts are stored in the pad, and the right pad
2836          * may not be active here, so check.
2837          * Looks like only during compiling the pads are illegal.
2838          */
2839 #ifdef USE_ITHREADS
2840         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2841 #endif
2842             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2843         break;
2844     case OP_GVSV:
2845     case OP_GV:
2846         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2847                 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
2848         break;
2849
2850     case OP_PADSV:
2851     case OP_PADAV:
2852     case OP_PADHV:
2853     case OP_ARGELEM:
2854         S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2855         break;
2856
2857     case OP_PADRANGE:
2858         S_deb_padvar(aTHX_ o->op_targ,
2859                         o->op_private & OPpPADRANGE_COUNTMASK, 1);
2860         break;
2861
2862     case OP_MULTIDEREF:
2863         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2864             SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2865         break;
2866
2867     case OP_MULTICONCAT:
2868         PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2869             SVfARG(multiconcat_stringify(o)));
2870         break;
2871
2872     default:
2873         break;
2874     }
2875     PerlIO_printf(Perl_debug_log, "\n");
2876     return 0;
2877 }
2878
2879
2880 /*
2881 =for apidoc op_class
2882
2883 Given an op, determine what type of struct it has been allocated as.
2884 Returns one of the OPclass enums, such as OPclass_LISTOP.
2885
2886 =cut
2887 */
2888
2889
2890 OPclass
2891 Perl_op_class(pTHX_ const OP *o)
2892 {
2893     bool custom = 0;
2894
2895     if (!o)
2896         return OPclass_NULL;
2897
2898     if (o->op_type == 0) {
2899         if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2900             return OPclass_COP;
2901         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2902     }
2903
2904     if (o->op_type == OP_SASSIGN)
2905         return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2906
2907     if (o->op_type == OP_AELEMFAST) {
2908 #ifdef USE_ITHREADS
2909             return OPclass_PADOP;
2910 #else
2911             return OPclass_SVOP;
2912 #endif
2913     }
2914
2915 #ifdef USE_ITHREADS
2916     if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2917         o->op_type == OP_RCATLINE)
2918         return OPclass_PADOP;
2919 #endif
2920
2921     if (o->op_type == OP_CUSTOM)
2922         custom = 1;
2923
2924     switch (OP_CLASS(o)) {
2925     case OA_BASEOP:
2926         return OPclass_BASEOP;
2927
2928     case OA_UNOP:
2929         return OPclass_UNOP;
2930
2931     case OA_BINOP:
2932         return OPclass_BINOP;
2933
2934     case OA_LOGOP:
2935         return OPclass_LOGOP;
2936
2937     case OA_LISTOP:
2938         return OPclass_LISTOP;
2939
2940     case OA_PMOP:
2941         return OPclass_PMOP;
2942
2943     case OA_SVOP:
2944         return OPclass_SVOP;
2945
2946     case OA_PADOP:
2947         return OPclass_PADOP;
2948
2949     case OA_PVOP_OR_SVOP:
2950         /*
2951          * Character translations (tr///) are usually a PVOP, keeping a
2952          * pointer to a table of shorts used to look up translations.
2953          * Under utf8, however, a simple table isn't practical; instead,
2954          * the OP is an SVOP (or, under threads, a PADOP),
2955          * and the SV is a reference to a swash
2956          * (i.e., an RV pointing to an HV).
2957          */
2958         return (!custom &&
2959                    (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2960                )
2961 #if  defined(USE_ITHREADS)
2962                 ? OPclass_PADOP : OPclass_PVOP;
2963 #else
2964                 ? OPclass_SVOP : OPclass_PVOP;
2965 #endif
2966
2967     case OA_LOOP:
2968         return OPclass_LOOP;
2969
2970     case OA_COP:
2971         return OPclass_COP;
2972
2973     case OA_BASEOP_OR_UNOP:
2974         /*
2975          * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2976          * whether parens were seen. perly.y uses OPf_SPECIAL to
2977          * signal whether a BASEOP had empty parens or none.
2978          * Some other UNOPs are created later, though, so the best
2979          * test is OPf_KIDS, which is set in newUNOP.
2980          */
2981         return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2982
2983     case OA_FILESTATOP:
2984         /*
2985          * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2986          * the OPf_REF flag to distinguish between OP types instead of the
2987          * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2988          * return OPclass_UNOP so that walkoptree can find our children. If
2989          * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2990          * (no argument to the operator) it's an OP; with OPf_REF set it's
2991          * an SVOP (and op_sv is the GV for the filehandle argument).
2992          */
2993         return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2994 #ifdef USE_ITHREADS
2995                 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2996 #else
2997                 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
2998 #endif
2999     case OA_LOOPEXOP:
3000         /*
3001          * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
3002          * label was omitted (in which case it's a BASEOP) or else a term was
3003          * seen. In this last case, all except goto are definitely PVOP but
3004          * goto is either a PVOP (with an ordinary constant label), an UNOP
3005          * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
3006          * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3007          * get set.
3008          */
3009         if (o->op_flags & OPf_STACKED)
3010             return OPclass_UNOP;
3011         else if (o->op_flags & OPf_SPECIAL)
3012             return OPclass_BASEOP;
3013         else
3014             return OPclass_PVOP;
3015     case OA_METHOP:
3016         return OPclass_METHOP;
3017     case OA_UNOP_AUX:
3018         return OPclass_UNOP_AUX;
3019     }
3020     Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3021          OP_NAME(o));
3022     return OPclass_BASEOP;
3023 }
3024
3025
3026
3027 STATIC CV*
3028 S_deb_curcv(pTHX_ I32 ix)
3029 {
3030     PERL_SI *si = PL_curstackinfo;
3031     for (; ix >=0; ix--) {
3032         const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3033
3034         if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3035             return cx->blk_sub.cv;
3036         else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3037             return cx->blk_eval.cv;
3038         else if (ix == 0 && si->si_type == PERLSI_MAIN)
3039             return PL_main_cv;
3040         else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3041                && si->si_type == PERLSI_SORT)
3042         {
3043             /* fake sort sub; use CV of caller */
3044             si = si->si_prev;
3045             ix = si->si_cxix + 1;
3046         }
3047     }
3048     return NULL;
3049 }
3050
3051 void
3052 Perl_watch(pTHX_ char **addr)
3053 {
3054     PERL_ARGS_ASSERT_WATCH;
3055
3056     PL_watchaddr = addr;
3057     PL_watchok = *addr;
3058     PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
3059         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3060 }
3061
3062 STATIC void
3063 S_debprof(pTHX_ const OP *o)
3064 {
3065     PERL_ARGS_ASSERT_DEBPROF;
3066
3067     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
3068         return;
3069     if (!PL_profiledata)
3070         Newxz(PL_profiledata, MAXO, U32);
3071     ++PL_profiledata[o->op_type];
3072 }
3073
3074 void
3075 Perl_debprofdump(pTHX)
3076 {
3077     unsigned i;
3078     if (!PL_profiledata)
3079         return;
3080     for (i = 0; i < MAXO; i++) {
3081         if (PL_profiledata[i])
3082             PerlIO_printf(Perl_debug_log,
3083                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
3084                                        PL_op_name[i]);
3085     }
3086 }
3087
3088
3089 /*
3090  * ex: set ts=8 sts=4 sw=4 et:
3091  */