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
  25 #include "EXTERN.h"
  26 #define PERL_IN_DUMP_C
  27 #include "perl.h"
  28 #include "regcomp.h"
  29 #include "proto.h"
  30
  31
  32 static const char* const svtypenames[SVt_LAST] = {
  33     "NULL",
  34     "BIND",
  35     "IV",
  36     "NV",
  37     "PV",
  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     "BIND",
  55     "IV",
  56     "NV",
  57     "PV",
  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), (flags) + C_ARRAY_LENGTH(flags))
  88
  89
  90 #define Sequence PL_op_sequence
  91
  92 void
  93 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
  94 {
  95     va_list args;
  96     PERL_ARGS_ASSERT_DUMP_INDENT;
  97     va_start(args, pat);
  98     dump_vindent(level, file, pat, &args);
  99     va_end(args);
 100 }
 101
 102 void
 103 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
 104 {
 105     dVAR;
 106     PERL_ARGS_ASSERT_DUMP_VINDENT;
 107     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
 108     PerlIO_vprintf(file, pat, *args);
 109 }
 110
 111 void
 112 Perl_dump_all(pTHX)
 113 {
 114     dump_all_perl(FALSE);
 115 }
 116
 117 void
 118 Perl_dump_all_perl(pTHX_ bool justperl)
 119 {
 120
 121     dVAR;
 122     PerlIO_setlinebuf(Perl_debug_log);
 123     if (PL_main_root)
 124         op_dump(PL_main_root);
 125     dump_packsubs_perl(PL_defstash, justperl);
 126 }
 127
 128 void
 129 Perl_dump_packsubs(pTHX_ const HV *stash)
 130 {
 131     PERL_ARGS_ASSERT_DUMP_PACKSUBS;
 132     dump_packsubs_perl(stash, FALSE);
 133 }
 134
 135 void
 136 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
 137 {
 138     dVAR;
 139     I32 i;
 140
 141     PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
 142
 143     if (!HvARRAY(stash))
 144         return;
 145     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 146         const HE *entry;
 147         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 148             const GV * const gv = (const GV *)HeVAL(entry);
 149             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 150                 continue;
 151             if (GvCVu(gv))
 152                 dump_sub_perl(gv, justperl);
 153             if (GvFORM(gv))
 154                 dump_form(gv);
 155             if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
 156                 const HV * const hv = GvHV(gv);
 157                 if (hv && (hv != PL_defstash))
 158                     dump_packsubs_perl(hv, justperl); /* nested package */
 159             }
 160         }
 161     }
 162 }
 163
 164 void
 165 Perl_dump_sub(pTHX_ const GV *gv)
 166 {
 167     PERL_ARGS_ASSERT_DUMP_SUB;
 168     dump_sub_perl(gv, FALSE);
 169 }
 170
 171 void
 172 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
 173 {
 174     SV * sv;
 175
 176     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
 177
 178     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
 179         return;
 180
 181     sv = sv_newmortal();
 182     gv_fullname3(sv, gv, NULL);
 183     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
 184     if (CvISXSUB(GvCV(gv)))
 185         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
 186             PTR2UV(CvXSUB(GvCV(gv))),
 187             (int)CvXSUBANY(GvCV(gv)).any_i32);
 188     else if (CvROOT(GvCV(gv)))
 189         op_dump(CvROOT(GvCV(gv)));
 190     else
 191         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 192 }
 193
 194 void
 195 Perl_dump_form(pTHX_ const GV *gv)
 196 {
 197     SV * const sv = sv_newmortal();
 198
 199     PERL_ARGS_ASSERT_DUMP_FORM;
 200
 201     gv_fullname3(sv, gv, NULL);
 202     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
 203     if (CvROOT(GvFORM(gv)))
 204         op_dump(CvROOT(GvFORM(gv)));
 205     else
 206         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 207 }
 208
 209 void
 210 Perl_dump_eval(pTHX)
 211 {
 212     dVAR;
 213     op_dump(PL_eval_root);
 214 }
 215
 216
 217 /*
 218 =for apidoc pv_escape
 219
 220 Escapes at most the first "count" chars of pv and puts the results into
 221 dsv such that the size of the escaped string will not exceed "max" chars
 222 and will not contain any incomplete escape sequences.
 223
 224 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
 225 will also be escaped.
 226
 227 Normally the SV will be cleared before the escaped string is prepared,
 228 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
 229
 230 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
 231 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
 232 using C<is_utf8_string()> to determine if it is Unicode.
 233
 234 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
 235 using C<\x01F1> style escapes, otherwise only chars above 255 will be
 236 escaped using this style, other non printable chars will use octal or
 237 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
 238 then all chars below 255 will be treated as printable and
 239 will be output as literals.
 240
 241 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
 242 string will be escaped, regardles of max. If the string is utf8 and
 243 the chars value is >255 then it will be returned as a plain hex
 244 sequence. Thus the output will either be a single char,
 245 an octal escape sequence, a special escape like C<\n> or a 3 or
 246 more digit hex value.
 247
 248 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
 249 not a '\\'. This is because regexes very often contain backslashed
 250 sequences, whereas '%' is not a particularly common character in patterns.
 251
 252 Returns a pointer to the escaped text as held by dsv.
 253
 254 =cut
 255 */
 256 #define PV_ESCAPE_OCTBUFSIZE 32
 257
 258 char *
 259 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
 260                 const STRLEN count, const STRLEN max,
 261                 STRLEN * const escaped, const U32 flags )
 262 {
 263     const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
 264     const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
 265     char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
 266     STRLEN wrote = 0;    /* chars written so far */
 267     STRLEN chsize = 0;   /* size of data to be written */
 268     STRLEN readsize = 1; /* size of data just read */
 269     bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
 270     const char *pv  = str;
 271     const char * const end = pv + count; /* end of string */
 272     octbuf[0] = esc;
 273
 274     PERL_ARGS_ASSERT_PV_ESCAPE;
 275
 276     if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
 277             /* This won't alter the UTF-8 flag */
 278             sv_setpvs(dsv, "");
 279     }
 280
 281     if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
 282         isuni = 1;
 283
 284     for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
 285         const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
 286         const U8 c = (U8)u & 0xFF;
 287
 288         if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
 289             if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
 290                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 291                                       "%"UVxf, u);
 292             else
 293                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 294                                       "%cx{%"UVxf"}", esc, u);
 295         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
 296             chsize = 1;
 297         } else {
 298             if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
 299                 chsize = 2;
 300                 switch (c) {
 301
 302                 case '\\' : /* fallthrough */
 303                 case '%'  : if ( c == esc )  {
 304                                 octbuf[1] = esc;
 305                             } else {
 306                                 chsize = 1;
 307                             }
 308                             break;
 309                 case '\v' : octbuf[1] = 'v';  break;
 310                 case '\t' : octbuf[1] = 't';  break;
 311                 case '\r' : octbuf[1] = 'r';  break;
 312                 case '\n' : octbuf[1] = 'n';  break;
 313                 case '\f' : octbuf[1] = 'f';  break;
 314                 case '"'  :
 315                         if ( dq == '"' )
 316                                 octbuf[1] = '"';
 317                         else
 318                             chsize = 1;
 319                         break;
 320                 default:
 321                         if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
 322                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 323                                                   "%c%03o", esc, c);
 324                         else
 325                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 326                                                   "%c%o", esc, c);
 327                 }
 328             } else {
 329                 chsize = 1;
 330             }
 331         }
 332         if ( max && (wrote + chsize > max) ) {
 333             break;
 334         } else if (chsize > 1) {
 335             sv_catpvn(dsv, octbuf, chsize);
 336             wrote += chsize;
 337         } else {
 338             /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
 339                128-255 can be appended raw to the dsv. If dsv happens to be
 340                UTF-8 then we need catpvf to upgrade them for us.
 341                Or add a new API call sv_catpvc(). Think about that name, and
 342                how to keep it clear that it's unlike the s of catpvs, which is
 343                really an array octets, not a string.  */
 344             Perl_sv_catpvf( aTHX_ dsv, "%c", c);
 345             wrote++;
 346         }
 347         if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
 348             break;
 349     }
 350     if (escaped != NULL)
 351         *escaped= pv - str;
 352     return SvPVX(dsv);
 353 }
 354 /*
 355 =for apidoc pv_pretty
 356
 357 Converts a string into something presentable, handling escaping via
 358 pv_escape() and supporting quoting and ellipses.
 359
 360 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
 361 double quoted with any double quotes in the string escaped. Otherwise
 362 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
 363 angle brackets.
 364
 365 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
 366 string were output then an ellipsis C<...> will be appended to the
 367 string. Note that this happens AFTER it has been quoted.
 368
 369 If start_color is non-null then it will be inserted after the opening
 370 quote (if there is one) but before the escaped text. If end_color
 371 is non-null then it will be inserted after the escaped text but before
 372 any quotes or ellipses.
 373
 374 Returns a pointer to the prettified text as held by dsv.
 375
 376 =cut
 377 */
 378
 379 char *
 380 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
 381   const STRLEN max, char const * const start_color, char const * const end_color,
 382   const U32 flags )
 383 {
 384     const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
 385     STRLEN escaped;
 386
 387     PERL_ARGS_ASSERT_PV_PRETTY;
 388
 389     if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
 390             /* This won't alter the UTF-8 flag */
 391             sv_setpvs(dsv, "");
 392     }
 393
 394     if ( dq == '"' )
 395         sv_catpvs(dsv, "\"");
 396     else if ( flags & PERL_PV_PRETTY_LTGT )
 397         sv_catpvs(dsv, "<");
 398
 399     if ( start_color != NULL )
 400         sv_catpv(dsv, start_color);
 401
 402     pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
 403
 404     if ( end_color != NULL )
 405         sv_catpv(dsv, end_color);
 406
 407     if ( dq == '"' )
 408         sv_catpvs( dsv, "\"");
 409     else if ( flags & PERL_PV_PRETTY_LTGT )
 410         sv_catpvs(dsv, ">");
 411
 412     if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
 413             sv_catpvs(dsv, "...");
 414
 415     return SvPVX(dsv);
 416 }
 417
 418 /*
 419 =for apidoc pv_display
 420
 421 Similar to
 422
 423   pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
 424
 425 except that an additional "\0" will be appended to the string when
 426 len > cur and pv[cur] is "\0".
 427
 428 Note that the final string may be up to 7 chars longer than pvlim.
 429
 430 =cut
 431 */
 432
 433 char *
 434 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
 435 {
 436     PERL_ARGS_ASSERT_PV_DISPLAY;
 437
 438     pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
 439     if (len > cur && pv[cur] == '\0')
 440             sv_catpvs( dsv, "\\0");
 441     return SvPVX(dsv);
 442 }
 443
 444 char *
 445 Perl_sv_peek(pTHX_ SV *sv)
 446 {
 447     dVAR;
 448     SV * const t = sv_newmortal();
 449     int unref = 0;
 450     U32 type;
 451
 452     sv_setpvs(t, "");
 453   retry:
 454     if (!sv) {
 455         sv_catpv(t, "VOID");
 456         goto finish;
 457     }
 458     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
 459         sv_catpv(t, "WILD");
 460         goto finish;
 461     }
 462     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
 463         if (sv == &PL_sv_undef) {
 464             sv_catpv(t, "SV_UNDEF");
 465             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 466                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 467                 SvREADONLY(sv))
 468                 goto finish;
 469         }
 470         else if (sv == &PL_sv_no) {
 471             sv_catpv(t, "SV_NO");
 472             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 473                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 474                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 475                                   SVp_POK|SVp_NOK)) &&
 476                 SvCUR(sv) == 0 &&
 477                 SvNVX(sv) == 0.0)
 478                 goto finish;
 479         }
 480         else if (sv == &PL_sv_yes) {
 481             sv_catpv(t, "SV_YES");
 482             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 483                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 484                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 485                                   SVp_POK|SVp_NOK)) &&
 486                 SvCUR(sv) == 1 &&
 487                 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
 488                 SvNVX(sv) == 1.0)
 489                 goto finish;
 490         }
 491         else {
 492             sv_catpv(t, "SV_PLACEHOLDER");
 493             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 494                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 495                 SvREADONLY(sv))
 496                 goto finish;
 497         }
 498         sv_catpv(t, ":");
 499     }
 500     else if (SvREFCNT(sv) == 0) {
 501         sv_catpv(t, "(");
 502         unref++;
 503     }
 504     else if (DEBUG_R_TEST_) {
 505         int is_tmp = 0;
 506         I32 ix;
 507         /* is this SV on the tmps stack? */
 508         for (ix=PL_tmps_ix; ix>=0; ix--) {
 509             if (PL_tmps_stack[ix] == sv) {
 510                 is_tmp = 1;
 511                 break;
 512             }
 513         }
 514         if (SvREFCNT(sv) > 1)
 515             Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
 516                     is_tmp ? "T" : "");
 517         else if (is_tmp)
 518             sv_catpv(t, "<T>");
 519     }
 520
 521     if (SvROK(sv)) {
 522         sv_catpv(t, "\\");
 523         if (SvCUR(t) + unref > 10) {
 524             SvCUR_set(t, unref + 3);
 525             *SvEND(t) = '\0';
 526             sv_catpv(t, "...");
 527             goto finish;
 528         }
 529         sv = SvRV(sv);
 530         goto retry;
 531     }
 532     type = SvTYPE(sv);
 533     if (type == SVt_PVCV) {
 534         Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
 535         goto finish;
 536     } else if (type < SVt_LAST) {
 537         sv_catpv(t, svshorttypenames[type]);
 538
 539         if (type == SVt_NULL)
 540             goto finish;
 541     } else {
 542         sv_catpv(t, "FREED");
 543         goto finish;
 544     }
 545
 546     if (SvPOKp(sv)) {
 547         if (!SvPVX_const(sv))
 548             sv_catpv(t, "(null)");
 549         else {
 550             SV * const tmp = newSVpvs("");
 551             sv_catpv(t, "(");
 552             if (SvOOK(sv)) {
 553                 STRLEN delta;
 554                 SvOOK_offset(sv, delta);
 555                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
 556             }
 557             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
 558             if (SvUTF8(sv))
 559                 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
 560                                sv_uni_display(tmp, sv, 6 * SvCUR(sv),
 561                                               UNI_DISPLAY_QQ));
 562             SvREFCNT_dec(tmp);
 563         }
 564     }
 565     else if (SvNOKp(sv)) {
 566         STORE_NUMERIC_LOCAL_SET_STANDARD();
 567         Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
 568         RESTORE_NUMERIC_LOCAL();
 569     }
 570     else if (SvIOKp(sv)) {
 571         if (SvIsUV(sv))
 572             Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
 573         else
 574             Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
 575     }
 576     else
 577         sv_catpv(t, "()");
 578
 579   finish:
 580     while (unref--)
 581         sv_catpv(t, ")");
 582     if (PL_tainting && SvTAINTED(sv))
 583         sv_catpv(t, " [tainted]");
 584     return SvPV_nolen(t);
 585 }
 586
 587 void
 588 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
 589 {
 590     char ch;
 591
 592     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
 593
 594     if (!pm) {
 595         Perl_dump_indent(aTHX_ level, file, "{}\n");
 596         return;
 597     }
 598     Perl_dump_indent(aTHX_ level, file, "{\n");
 599     level++;
 600     if (pm->op_pmflags & PMf_ONCE)
 601         ch = '?';
 602     else
 603         ch = '/';
 604     if (PM_GETRE(pm))
 605         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
 606              ch, RX_PRECOMP(PM_GETRE(pm)), ch,
 607              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
 608     else
 609         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
 610     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
 611         Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
 612         op_dump(pm->op_pmreplrootu.op_pmreplroot);
 613     }
 614     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
 615         SV * const tmpsv = pm_description(pm);
 616         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 617         SvREFCNT_dec(tmpsv);
 618     }
 619
 620     Perl_dump_indent(aTHX_ level-1, file, "}\n");
 621 }
 622
 623 const struct flag_to_name pmflags_flags_names[] = {
 624     {PMf_CONST, ",CONST"},
 625     {PMf_KEEP, ",KEEP"},
 626     {PMf_GLOBAL, ",GLOBAL"},
 627     {PMf_CONTINUE, ",CONTINUE"},
 628     {PMf_RETAINT, ",RETAINT"},
 629     {PMf_EVAL, ",EVAL"},
 630     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
 631 };
 632
 633 static SV *
 634 S_pm_description(pTHX_ const PMOP *pm)
 635 {
 636     SV * const desc = newSVpvs("");
 637     const REGEXP * const regex = PM_GETRE(pm);
 638     const U32 pmflags = pm->op_pmflags;
 639
 640     PERL_ARGS_ASSERT_PM_DESCRIPTION;
 641
 642     if (pmflags & PMf_ONCE)
 643         sv_catpv(desc, ",ONCE");
 644 #ifdef USE_ITHREADS
 645     if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
 646         sv_catpv(desc, ":USED");
 647 #else
 648     if (pmflags & PMf_USED)
 649         sv_catpv(desc, ":USED");
 650 #endif
 651
 652     if (regex) {
 653         if (RX_EXTFLAGS(regex) & RXf_TAINTED)
 654             sv_catpv(desc, ",TAINTED");
 655         if (RX_CHECK_SUBSTR(regex)) {
 656             if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
 657                 sv_catpv(desc, ",SCANFIRST");
 658             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
 659                 sv_catpv(desc, ",ALL");
 660         }
 661         if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
 662             sv_catpv(desc, ",SKIPWHITE");
 663     }
 664
 665     append_flags(desc, pmflags, pmflags_flags_names);
 666     return desc;
 667 }
 668
 669 void
 670 Perl_pmop_dump(pTHX_ PMOP *pm)
 671 {
 672     do_pmop_dump(0, Perl_debug_log, pm);
 673 }
 674
 675 /* An op sequencer.  We visit the ops in the order they're to execute. */
 676
 677 STATIC void
 678 S_sequence(pTHX_ register const OP *o)
 679 {
 680     dVAR;
 681     const OP *oldop = NULL;
 682
 683     if (!o)
 684         return;
 685
 686 #ifdef PERL_MAD
 687     if (o->op_next == 0)
 688         return;
 689 #endif
 690
 691     if (!Sequence)
 692         Sequence = newHV();
 693
 694     for (; o; o = o->op_next) {
 695         STRLEN len;
 696         SV * const op = newSVuv(PTR2UV(o));
 697         const char * const key = SvPV_const(op, len);
 698
 699         if (hv_exists(Sequence, key, len))
 700             break;
 701
 702         switch (o->op_type) {
 703         case OP_STUB:
 704             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
 705                 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 706                 break;
 707             }
 708             goto nothin;
 709         case OP_NULL:
 710 #ifdef PERL_MAD
 711             if (o == o->op_next)
 712                 return;
 713 #endif
 714             if (oldop && o->op_next)
 715                 continue;
 716             break;
 717         case OP_SCALAR:
 718         case OP_LINESEQ:
 719         case OP_SCOPE:
 720           nothin:
 721             if (oldop && o->op_next)
 722                 continue;
 723             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 724             break;
 725
 726         case OP_MAPWHILE:
 727         case OP_GREPWHILE:
 728         case OP_AND:
 729         case OP_OR:
 730         case OP_DOR:
 731         case OP_ANDASSIGN:
 732         case OP_ORASSIGN:
 733         case OP_DORASSIGN:
 734         case OP_COND_EXPR:
 735         case OP_RANGE:
 736             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 737             sequence_tail(cLOGOPo->op_other);
 738             break;
 739
 740         case OP_ENTERLOOP:
 741         case OP_ENTERITER:
 742             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 743             sequence_tail(cLOOPo->op_redoop);
 744             sequence_tail(cLOOPo->op_nextop);
 745             sequence_tail(cLOOPo->op_lastop);
 746             break;
 747
 748         case OP_SUBST:
 749             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 750             sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
 751             break;
 752
 753         case OP_QR:
 754         case OP_MATCH:
 755         case OP_HELEM:
 756             break;
 757
 758         default:
 759             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 760             break;
 761         }
 762         oldop = o;
 763     }
 764 }
 765
 766 static void
 767 S_sequence_tail(pTHX_ const OP *o)
 768 {
 769     while (o && (o->op_type == OP_NULL))
 770         o = o->op_next;
 771     sequence(o);
 772 }
 773
 774 STATIC UV
 775 S_sequence_num(pTHX_ const OP *o)
 776 {
 777     dVAR;
 778     SV     *op,
 779           **seq;
 780     const char *key;
 781     STRLEN  len;
 782     if (!o) return 0;
 783     op = newSVuv(PTR2UV(o));
 784     key = SvPV_const(op, len);
 785     seq = hv_fetch(Sequence, key, len, 0);
 786     return seq ? SvUV(*seq): 0;
 787 }
 788
 789 const struct flag_to_name op_flags_names[] = {
 790     {OPf_KIDS, ",KIDS"},
 791     {OPf_PARENS, ",PARENS"},
 792     {OPf_STACKED, ",STACKED"},
 793     {OPf_REF, ",REF"},
 794     {OPf_MOD, ",MOD"},
 795     {OPf_SPECIAL, ",SPECIAL"}
 796 };
 797
 798 const struct flag_to_name op_trans_names[] = {
 799     {OPpTRANS_SQUASH, ",SQUASH"},
 800     {OPpTRANS_DELETE, ",DELETE"},
 801     {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
 802     {OPpTRANS_IDENTICAL, ",IDENTICAL"},
 803     {OPpTRANS_GROWS, ",GROWS"}
 804 };
 805
 806 const struct flag_to_name op_entersub_names[] = {
 807     {OPpENTERSUB_AMPER, ",AMPER"},
 808     {OPpENTERSUB_DB, ",DB"},
 809     {OPpENTERSUB_HASTARG, ",HASTARG"},
 810     {OPpENTERSUB_NOPAREN, ",NOPAREN"},
 811     {OPpENTERSUB_INARGS, ",INARGS"},
 812     {OPpENTERSUB_NOMOD, ",NOMOD"}
 813 };
 814
 815 const struct flag_to_name op_const_names[] = {
 816     {OPpCONST_BARE, ",BARE"},
 817     {OPpCONST_STRICT, ",STRICT"},
 818     {OPpCONST_ARYBASE, ",ARYBASE"},
 819     {OPpCONST_WARNING, ",WARNING"},
 820     {OPpCONST_ENTERED, ",ENTERED"}
 821 };
 822
 823 const struct flag_to_name op_sort_names[] = {
 824     {OPpSORT_NUMERIC, ",NUMERIC"},
 825     {OPpSORT_INTEGER, ",INTEGER"},
 826     {OPpSORT_REVERSE, ",REVERSE"}
 827 };
 828
 829 const struct flag_to_name op_open_names[] = {
 830     {OPpOPEN_IN_RAW, ",IN_RAW"},
 831     {OPpOPEN_IN_CRLF, ",IN_CRLF"},
 832     {OPpOPEN_OUT_RAW, ",OUT_RAW"},
 833     {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
 834 };
 835
 836 void
 837 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 838 {
 839     dVAR;
 840     UV      seq;
 841     const OPCODE optype = o->op_type;
 842
 843     PERL_ARGS_ASSERT_DO_OP_DUMP;
 844
 845     sequence(o);
 846     Perl_dump_indent(aTHX_ level, file, "{\n");
 847     level++;
 848     seq = sequence_num(o);
 849     if (seq)
 850         PerlIO_printf(file, "%-4"UVuf, seq);
 851     else
 852         PerlIO_printf(file, "    ");
 853     PerlIO_printf(file,
 854                   "%*sTYPE = %s  ===> ",
 855                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
 856     if (o->op_next)
 857         PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
 858                                 sequence_num(o->op_next));
 859     else
 860         PerlIO_printf(file, "DONE\n");
 861     if (o->op_targ) {
 862         if (optype == OP_NULL) {
 863             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
 864             if (o->op_targ == OP_NEXTSTATE) {
 865                 if (CopLINE(cCOPo))
 866                     Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
 867                                      (UV)CopLINE(cCOPo));
 868                 if (CopSTASHPV(cCOPo))
 869                     Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
 870                                      CopSTASHPV(cCOPo));
 871                 if (CopLABEL(cCOPo))
 872                     Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
 873                                      CopLABEL(cCOPo));
 874             }
 875         }
 876         else
 877             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
 878     }
 879 #ifdef DUMPADDR
 880     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
 881 #endif
 882     if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
 883         SV * const tmpsv = newSVpvs("");
 884         switch (o->op_flags & OPf_WANT) {
 885         case OPf_WANT_VOID:
 886             sv_catpv(tmpsv, ",VOID");
 887             break;
 888         case OPf_WANT_SCALAR:
 889             sv_catpv(tmpsv, ",SCALAR");
 890             break;
 891         case OPf_WANT_LIST:
 892             sv_catpv(tmpsv, ",LIST");
 893             break;
 894         default:
 895             sv_catpv(tmpsv, ",UNKNOWN");
 896             break;
 897         }
 898         append_flags(tmpsv, o->op_flags, op_flags_names);
 899         if (o->op_latefree)
 900             sv_catpv(tmpsv, ",LATEFREE");
 901         if (o->op_latefreed)
 902             sv_catpv(tmpsv, ",LATEFREED");
 903         if (o->op_attached)
 904             sv_catpv(tmpsv, ",ATTACHED");
 905         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 906         SvREFCNT_dec(tmpsv);
 907     }
 908     if (o->op_private) {
 909         SV * const tmpsv = newSVpvs("");
 910         if (PL_opargs[optype] & OA_TARGLEX) {
 911             if (o->op_private & OPpTARGET_MY)
 912                 sv_catpv(tmpsv, ",TARGET_MY");
 913         }
 914         else if (optype == OP_LEAVESUB ||
 915                  optype == OP_LEAVE ||
 916                  optype == OP_LEAVESUBLV ||
 917                  optype == OP_LEAVEWRITE) {
 918             if (o->op_private & OPpREFCOUNTED)
 919                 sv_catpv(tmpsv, ",REFCOUNTED");
 920         }
 921         else if (optype == OP_AASSIGN) {
 922             if (o->op_private & OPpASSIGN_COMMON)
 923                 sv_catpv(tmpsv, ",COMMON");
 924         }
 925         else if (optype == OP_SASSIGN) {
 926             if (o->op_private & OPpASSIGN_BACKWARDS)
 927                 sv_catpv(tmpsv, ",BACKWARDS");
 928         }
 929         else if (optype == OP_TRANS) {
 930             append_flags(tmpsv, o->op_private, op_trans_names);
 931         }
 932         else if (optype == OP_REPEAT) {
 933             if (o->op_private & OPpREPEAT_DOLIST)
 934                 sv_catpv(tmpsv, ",DOLIST");
 935         }
 936         else if (optype == OP_ENTERSUB ||
 937                  optype == OP_RV2SV ||
 938                  optype == OP_GVSV ||
 939                  optype == OP_RV2AV ||
 940                  optype == OP_RV2HV ||
 941                  optype == OP_RV2GV ||
 942                  optype == OP_AELEM ||
 943                  optype == OP_HELEM )
 944         {
 945             if (optype == OP_ENTERSUB) {
 946                 append_flags(tmpsv, o->op_private, op_entersub_names);
 947             }
 948             else {
 949                 switch (o->op_private & OPpDEREF) {
 950                 case OPpDEREF_SV:
 951                     sv_catpv(tmpsv, ",SV");
 952                     break;
 953                 case OPpDEREF_AV:
 954                     sv_catpv(tmpsv, ",AV");
 955                     break;
 956                 case OPpDEREF_HV:
 957                     sv_catpv(tmpsv, ",HV");
 958                     break;
 959                 }
 960                 if (o->op_private & OPpMAYBE_LVSUB)
 961                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
 962             }
 963
 964             if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
 965                     && (o->op_private & OPpDEREFed))
 966                 sv_catpv(tmpsv, ",DEREFed");
 967
 968             if (optype == OP_AELEM || optype == OP_HELEM) {
 969                 if (o->op_private & OPpLVAL_DEFER)
 970                     sv_catpv(tmpsv, ",LVAL_DEFER");
 971             }
 972             else {
 973                 if (o->op_private & HINT_STRICT_REFS)
 974                     sv_catpv(tmpsv, ",STRICT_REFS");
 975                 if (o->op_private & OPpOUR_INTRO)
 976                     sv_catpv(tmpsv, ",OUR_INTRO");
 977             }
 978         }
 979         else if (optype == OP_CONST) {
 980             append_flags(tmpsv, o->op_private, op_const_names);
 981         }
 982         else if (optype == OP_FLIP) {
 983             if (o->op_private & OPpFLIP_LINENUM)
 984                 sv_catpv(tmpsv, ",LINENUM");
 985         }
 986         else if (optype == OP_FLOP) {
 987             if (o->op_private & OPpFLIP_LINENUM)
 988                 sv_catpv(tmpsv, ",LINENUM");
 989         }
 990         else if (optype == OP_RV2CV) {
 991             if (o->op_private & OPpLVAL_INTRO)
 992                 sv_catpv(tmpsv, ",INTRO");
 993         }
 994         else if (optype == OP_GV) {
 995             if (o->op_private & OPpEARLY_CV)
 996                 sv_catpv(tmpsv, ",EARLY_CV");
 997         }
 998         else if (optype == OP_LIST) {
 999             if (o->op_private & OPpLIST_GUESSED)
1000                 sv_catpv(tmpsv, ",GUESSED");
1001         }
1002         else if (optype == OP_DELETE) {
1003             if (o->op_private & OPpSLICE)
1004                 sv_catpv(tmpsv, ",SLICE");
1005         }
1006         else if (optype == OP_EXISTS) {
1007             if (o->op_private & OPpEXISTS_SUB)
1008                 sv_catpv(tmpsv, ",EXISTS_SUB");
1009         }
1010         else if (optype == OP_SORT) {
1011             append_flags(tmpsv, o->op_private, op_sort_names);
1012         }
1013         else if (optype == OP_OPEN || optype == OP_BACKTICK) {
1014             append_flags(tmpsv, o->op_private, op_open_names);
1015         }
1016         else if (optype == OP_EXIT) {
1017             if (o->op_private & OPpEXIT_VMSISH)
1018                 sv_catpv(tmpsv, ",EXIT_VMSISH");
1019             if (o->op_private & OPpHUSH_VMSISH)
1020                 sv_catpv(tmpsv, ",HUSH_VMSISH");
1021         }
1022         else if (optype == OP_DIE) {
1023             if (o->op_private & OPpHUSH_VMSISH)
1024                 sv_catpv(tmpsv, ",HUSH_VMSISH");
1025         }
1026         else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
1027             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1028                 sv_catpv(tmpsv, ",FT_ACCESS");
1029             if (o->op_private & OPpFT_STACKED)
1030                 sv_catpv(tmpsv, ",FT_STACKED");
1031         }
1032         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1033             sv_catpv(tmpsv, ",INTRO");
1034         if (SvCUR(tmpsv))
1035             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1036         SvREFCNT_dec(tmpsv);
1037     }
1038
1039 #ifdef PERL_MAD
1040     if (PL_madskills && o->op_madprop) {
1041         SV * const tmpsv = newSVpvs("");
1042         MADPROP* mp = o->op_madprop;
1043         Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1044         level++;
1045         while (mp) {
1046             const char tmp = mp->mad_key;
1047             sv_setpvs(tmpsv,"'");
1048             if (tmp)
1049                 sv_catpvn(tmpsv, &tmp, 1);
1050             sv_catpv(tmpsv, "'=");
1051             switch (mp->mad_type) {
1052             case MAD_NULL:
1053                 sv_catpv(tmpsv, "NULL");
1054                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1055                 break;
1056             case MAD_PV:
1057                 sv_catpv(tmpsv, "<");
1058                 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1059                 sv_catpv(tmpsv, ">");
1060                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1061                 break;
1062             case MAD_OP:
1063                 if ((OP*)mp->mad_val) {
1064                     Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1065                     do_op_dump(level, file, (OP*)mp->mad_val);
1066                 }
1067                 break;
1068             default:
1069                 sv_catpv(tmpsv, "(UNK)");
1070                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1071                 break;
1072             }
1073             mp = mp->mad_next;
1074         }
1075         level--;
1076         Perl_dump_indent(aTHX_ level, file, "}\n");
1077
1078         SvREFCNT_dec(tmpsv);
1079     }
1080 #endif
1081
1082     switch (optype) {
1083     case OP_AELEMFAST:
1084     case OP_GVSV:
1085     case OP_GV:
1086 #ifdef USE_ITHREADS
1087         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1088 #else
1089         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1090             if (cSVOPo->op_sv) {
1091                 SV * const tmpsv = newSV(0);
1092                 ENTER;
1093                 SAVEFREESV(tmpsv);
1094 #ifdef PERL_MAD
1095                 /* FIXME - is this making unwarranted assumptions about the
1096                    UTF-8 cleanliness of the dump file handle?  */
1097                 SvUTF8_on(tmpsv);
1098 #endif
1099                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1100                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1101                                  SvPV_nolen_const(tmpsv));
1102                 LEAVE;
1103             }
1104             else
1105                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1106         }
1107 #endif
1108         break;
1109     case OP_CONST:
1110     case OP_HINTSEVAL:
1111     case OP_METHOD_NAMED:
1112 #ifndef USE_ITHREADS
1113         /* with ITHREADS, consts are stored in the pad, and the right pad
1114          * may not be active here, so skip */
1115         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1116 #endif
1117         break;
1118     case OP_NEXTSTATE:
1119     case OP_DBSTATE:
1120         if (CopLINE(cCOPo))
1121             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1122                              (UV)CopLINE(cCOPo));
1123         if (CopSTASHPV(cCOPo))
1124             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1125                              CopSTASHPV(cCOPo));
1126         if (CopLABEL(cCOPo))
1127             Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1128                              CopLABEL(cCOPo));
1129         break;
1130     case OP_ENTERLOOP:
1131         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1132         if (cLOOPo->op_redoop)
1133             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1134         else
1135             PerlIO_printf(file, "DONE\n");
1136         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1137         if (cLOOPo->op_nextop)
1138             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1139         else
1140             PerlIO_printf(file, "DONE\n");
1141         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1142         if (cLOOPo->op_lastop)
1143             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1144         else
1145             PerlIO_printf(file, "DONE\n");
1146         break;
1147     case OP_COND_EXPR:
1148     case OP_RANGE:
1149     case OP_MAPWHILE:
1150     case OP_GREPWHILE:
1151     case OP_OR:
1152     case OP_AND:
1153         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1154         if (cLOGOPo->op_other)
1155             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1156         else
1157             PerlIO_printf(file, "DONE\n");
1158         break;
1159     case OP_PUSHRE:
1160     case OP_MATCH:
1161     case OP_QR:
1162     case OP_SUBST:
1163         do_pmop_dump(level, file, cPMOPo);
1164         break;
1165     case OP_LEAVE:
1166     case OP_LEAVEEVAL:
1167     case OP_LEAVESUB:
1168     case OP_LEAVESUBLV:
1169     case OP_LEAVEWRITE:
1170     case OP_SCOPE:
1171         if (o->op_private & OPpREFCOUNTED)
1172             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1173         break;
1174     default:
1175         break;
1176     }
1177     if (o->op_flags & OPf_KIDS) {
1178         OP *kid;
1179         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1180             do_op_dump(level, file, kid);
1181     }
1182     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1183 }
1184
1185 void
1186 Perl_op_dump(pTHX_ const OP *o)
1187 {
1188     PERL_ARGS_ASSERT_OP_DUMP;
1189     do_op_dump(0, Perl_debug_log, o);
1190 }
1191
1192 void
1193 Perl_gv_dump(pTHX_ GV *gv)
1194 {
1195     SV *sv;
1196
1197     PERL_ARGS_ASSERT_GV_DUMP;
1198
1199     if (!gv) {
1200         PerlIO_printf(Perl_debug_log, "{}\n");
1201         return;
1202     }
1203     sv = sv_newmortal();
1204     PerlIO_printf(Perl_debug_log, "{\n");
1205     gv_fullname3(sv, gv, NULL);
1206     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1207     if (gv != GvEGV(gv)) {
1208         gv_efullname3(sv, GvEGV(gv), NULL);
1209         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1210     }
1211     PerlIO_putc(Perl_debug_log, '\n');
1212     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1213 }
1214
1215
1216 /* map magic types to the symbolic names
1217  * (with the PERL_MAGIC_ prefixed stripped)
1218  */
1219
1220 static const struct { const char type; const char *name; } magic_names[] = {
1221         { PERL_MAGIC_sv,             "sv(\\0)" },
1222         { PERL_MAGIC_arylen,         "arylen(#)" },
1223         { PERL_MAGIC_rhash,          "rhash(%)" },
1224         { PERL_MAGIC_pos,            "pos(.)" },
1225         { PERL_MAGIC_symtab,         "symtab(:)" },
1226         { PERL_MAGIC_backref,        "backref(<)" },
1227         { PERL_MAGIC_arylen_p,       "arylen_p(@)" },
1228         { PERL_MAGIC_overload,       "overload(A)" },
1229         { PERL_MAGIC_bm,             "bm(B)" },
1230         { PERL_MAGIC_regdata,        "regdata(D)" },
1231         { PERL_MAGIC_env,            "env(E)" },
1232         { PERL_MAGIC_hints,          "hints(H)" },
1233         { PERL_MAGIC_isa,            "isa(I)" },
1234         { PERL_MAGIC_dbfile,         "dbfile(L)" },
1235         { PERL_MAGIC_shared,         "shared(N)" },
1236         { PERL_MAGIC_tied,           "tied(P)" },
1237         { PERL_MAGIC_sig,            "sig(S)" },
1238         { PERL_MAGIC_uvar,           "uvar(U)" },
1239         { PERL_MAGIC_overload_elem,  "overload_elem(a)" },
1240         { PERL_MAGIC_overload_table, "overload_table(c)" },
1241         { PERL_MAGIC_regdatum,       "regdatum(d)" },
1242         { PERL_MAGIC_envelem,        "envelem(e)" },
1243         { PERL_MAGIC_fm,             "fm(f)" },
1244         { PERL_MAGIC_regex_global,   "regex_global(g)" },
1245         { PERL_MAGIC_hintselem,      "hintselem(h)" },
1246         { PERL_MAGIC_isaelem,        "isaelem(i)" },
1247         { PERL_MAGIC_nkeys,          "nkeys(k)" },
1248         { PERL_MAGIC_dbline,         "dbline(l)" },
1249         { PERL_MAGIC_shared_scalar,  "shared_scalar(n)" },
1250         { PERL_MAGIC_collxfrm,       "collxfrm(o)" },
1251         { PERL_MAGIC_tiedelem,       "tiedelem(p)" },
1252         { PERL_MAGIC_tiedscalar,     "tiedscalar(q)" },
1253         { PERL_MAGIC_qr,             "qr(r)" },
1254         { PERL_MAGIC_sigelem,        "sigelem(s)" },
1255         { PERL_MAGIC_taint,          "taint(t)" },
1256         { PERL_MAGIC_uvar_elem,      "uvar_elem(u)" },
1257         { PERL_MAGIC_vec,            "vec(v)" },
1258         { PERL_MAGIC_vstring,        "vstring(V)" },
1259         { PERL_MAGIC_utf8,           "utf8(w)" },
1260         { PERL_MAGIC_substr,         "substr(x)" },
1261         { PERL_MAGIC_defelem,        "defelem(y)" },
1262         { PERL_MAGIC_ext,            "ext(~)" },
1263         /* this null string terminates the list */
1264         { 0,                         NULL },
1265 };
1266
1267 void
1268 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1269 {
1270     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1271
1272     for (; mg; mg = mg->mg_moremagic) {
1273         Perl_dump_indent(aTHX_ level, file,
1274                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1275         if (mg->mg_virtual) {
1276             const MGVTBL * const v = mg->mg_virtual;
1277             const char *s;
1278             if      (v == &PL_vtbl_sv)         s = "sv";
1279             else if (v == &PL_vtbl_env)        s = "env";
1280             else if (v == &PL_vtbl_envelem)    s = "envelem";
1281             else if (v == &PL_vtbl_sig)        s = "sig";
1282             else if (v == &PL_vtbl_sigelem)    s = "sigelem";
1283             else if (v == &PL_vtbl_pack)       s = "pack";
1284             else if (v == &PL_vtbl_packelem)   s = "packelem";
1285             else if (v == &PL_vtbl_dbline)     s = "dbline";
1286             else if (v == &PL_vtbl_isa)        s = "isa";
1287             else if (v == &PL_vtbl_arylen)     s = "arylen";
1288             else if (v == &PL_vtbl_mglob)      s = "mglob";
1289             else if (v == &PL_vtbl_nkeys)      s = "nkeys";
1290             else if (v == &PL_vtbl_taint)      s = "taint";
1291             else if (v == &PL_vtbl_substr)     s = "substr";
1292             else if (v == &PL_vtbl_vec)        s = "vec";
1293             else if (v == &PL_vtbl_pos)        s = "pos";
1294             else if (v == &PL_vtbl_bm)         s = "bm";
1295             else if (v == &PL_vtbl_fm)         s = "fm";
1296             else if (v == &PL_vtbl_uvar)       s = "uvar";
1297             else if (v == &PL_vtbl_defelem)    s = "defelem";
1298 #ifdef USE_LOCALE_COLLATE
1299             else if (v == &PL_vtbl_collxfrm)   s = "collxfrm";
1300 #endif
1301             else if (v == &PL_vtbl_amagic)     s = "amagic";
1302             else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1303             else if (v == &PL_vtbl_backref)    s = "backref";
1304             else if (v == &PL_vtbl_utf8)       s = "utf8";
1305             else if (v == &PL_vtbl_arylen_p)   s = "arylen_p";
1306             else if (v == &PL_vtbl_hintselem)  s = "hintselem";
1307             else if (v == &PL_vtbl_hints)      s = "hints";
1308             else                               s = NULL;
1309             if (s)
1310                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
1311             else
1312                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1313         }
1314         else
1315             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1316
1317         if (mg->mg_private)
1318             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1319
1320         {
1321             int n;
1322             const char *name = NULL;
1323             for (n = 0; magic_names[n].name; n++) {
1324                 if (mg->mg_type == magic_names[n].type) {
1325                     name = magic_names[n].name;
1326                     break;
1327                 }
1328             }
1329             if (name)
1330                 Perl_dump_indent(aTHX_ level, file,
1331                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1332             else
1333                 Perl_dump_indent(aTHX_ level, file,
1334                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1335         }
1336
1337         if (mg->mg_flags) {
1338             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1339             if (mg->mg_type == PERL_MAGIC_envelem &&
1340                 mg->mg_flags & MGf_TAINTEDDIR)
1341                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1342             if (mg->mg_flags & MGf_REFCOUNTED)
1343                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1344             if (mg->mg_flags & MGf_GSKIP)
1345                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1346             if (mg->mg_type == PERL_MAGIC_regex_global &&
1347                 mg->mg_flags & MGf_MINMATCH)
1348                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1349         }
1350         if (mg->mg_obj) {
1351             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1352                 PTR2UV(mg->mg_obj));
1353             if (mg->mg_type == PERL_MAGIC_qr) {
1354                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1355                 SV * const dsv = sv_newmortal();
1356                 const char * const s
1357                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1358                     60, NULL, NULL,
1359                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1360                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1361                 );
1362                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1363                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1364                         (IV)RX_REFCNT(re));
1365             }
1366             if (mg->mg_flags & MGf_REFCOUNTED)
1367                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1368         }
1369         if (mg->mg_len)
1370             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1371         if (mg->mg_ptr) {
1372             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1373             if (mg->mg_len >= 0) {
1374                 if (mg->mg_type != PERL_MAGIC_utf8) {
1375                     SV * const sv = newSVpvs("");
1376                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1377                     SvREFCNT_dec(sv);
1378                 }
1379             }
1380             else if (mg->mg_len == HEf_SVKEY) {
1381                 PerlIO_puts(file, " => HEf_SVKEY\n");
1382                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1383                            maxnest, dumpops, pvlim); /* MG is already +1 */
1384                 continue;
1385             }
1386             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1387             else
1388                 PerlIO_puts(
1389                   file,
1390                  " ???? - " __FILE__
1391                  " does not know how to handle this MG_LEN"
1392                 );
1393             PerlIO_putc(file, '\n');
1394         }
1395         if (mg->mg_type == PERL_MAGIC_utf8) {
1396             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1397             if (cache) {
1398                 IV i;
1399                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1400                     Perl_dump_indent(aTHX_ level, file,
1401                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1402                                      i,
1403                                      (UV)cache[i * 2],
1404                                      (UV)cache[i * 2 + 1]);
1405             }
1406         }
1407     }
1408 }
1409
1410 void
1411 Perl_magic_dump(pTHX_ const MAGIC *mg)
1412 {
1413     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1414 }
1415
1416 void
1417 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1418 {
1419     const char *hvname;
1420
1421     PERL_ARGS_ASSERT_DO_HV_DUMP;
1422
1423     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1424     if (sv && (hvname = HvNAME_get(sv)))
1425         PerlIO_printf(file, "\t\"%s\"\n", hvname);
1426     else
1427         PerlIO_putc(file, '\n');
1428 }
1429
1430 void
1431 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1432 {
1433     PERL_ARGS_ASSERT_DO_GV_DUMP;
1434
1435     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1436     if (sv && GvNAME(sv))
1437         PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1438     else
1439         PerlIO_putc(file, '\n');
1440 }
1441
1442 void
1443 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1444 {
1445     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1446
1447     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1448     if (sv && GvNAME(sv)) {
1449         const char *hvname;
1450         PerlIO_printf(file, "\t\"");
1451         if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1452             PerlIO_printf(file, "%s\" :: \"", hvname);
1453         PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1454     }
1455     else
1456         PerlIO_putc(file, '\n');
1457 }
1458
1459 const struct flag_to_name first_sv_flags_names[] = {
1460     {SVs_TEMP, "TEMP,"},
1461     {SVs_OBJECT, "OBJECT,"},
1462     {SVs_GMG, "GMG,"},
1463     {SVs_SMG, "SMG,"},
1464     {SVs_RMG, "RMG,"},
1465     {SVf_IOK, "IOK,"},
1466     {SVf_NOK, "NOK,"},
1467     {SVf_POK, "POK,"}
1468 };
1469
1470 const struct flag_to_name second_sv_flags_names[] = {
1471     {SVf_OOK, "OOK,"},
1472     {SVf_FAKE, "FAKE,"},
1473     {SVf_READONLY, "READONLY,"},
1474     {SVf_BREAK, "BREAK,"},
1475     {SVf_AMAGIC, "OVERLOAD,"},
1476     {SVp_IOK, "pIOK,"},
1477     {SVp_NOK, "pNOK,"},
1478     {SVp_POK, "pPOK,"}
1479 };
1480
1481 void
1482 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1483 {
1484     dVAR;
1485     SV *d;
1486     const char *s;
1487     U32 flags;
1488     U32 type;
1489
1490     PERL_ARGS_ASSERT_DO_SV_DUMP;
1491
1492     if (!sv) {
1493         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1494         return;
1495     }
1496
1497     flags = SvFLAGS(sv);
1498     type = SvTYPE(sv);
1499
1500     d = Perl_newSVpvf(aTHX_
1501                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1502                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1503                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1504                    (int)(PL_dumpindent*level), "");
1505
1506     if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1507         if (flags & SVs_PADSTALE)       sv_catpv(d, "PADSTALE,");
1508     }
1509     if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1510         if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1511         if (flags & SVs_PADMY)  sv_catpv(d, "PADMY,");
1512     }
1513     append_flags(d, flags, first_sv_flags_names);
1514     if (flags & SVf_ROK)  {
1515                                 sv_catpv(d, "ROK,");
1516         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1517     }
1518     append_flags(d, flags, second_sv_flags_names);
1519     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1520         if (SvPCS_IMPORTED(sv))
1521                                 sv_catpv(d, "PCS_IMPORTED,");
1522         else
1523                                 sv_catpv(d, "SCREAM,");
1524     }
1525
1526     switch (type) {
1527     case SVt_PVCV:
1528     case SVt_PVFM:
1529         if (CvANON(sv))         sv_catpv(d, "ANON,");
1530         if (CvUNIQUE(sv))       sv_catpv(d, "UNIQUE,");
1531         if (CvCLONE(sv))        sv_catpv(d, "CLONE,");
1532         if (CvCLONED(sv))       sv_catpv(d, "CLONED,");
1533         if (CvCONST(sv))        sv_catpv(d, "CONST,");
1534         if (CvNODEBUG(sv))      sv_catpv(d, "NODEBUG,");
1535         if (SvCOMPILED(sv))     sv_catpv(d, "COMPILED,");
1536         if (CvLVALUE(sv))       sv_catpv(d, "LVALUE,");
1537         if (CvMETHOD(sv))       sv_catpv(d, "METHOD,");
1538         if (CvWEAKOUTSIDE(sv))  sv_catpv(d, "WEAKOUTSIDE,");
1539         break;
1540     case SVt_PVHV:
1541         if (HvSHAREKEYS(sv))    sv_catpv(d, "SHAREKEYS,");
1542         if (HvLAZYDEL(sv))      sv_catpv(d, "LAZYDEL,");
1543         if (HvHASKFLAGS(sv))    sv_catpv(d, "HASKFLAGS,");
1544         if (HvREHASH(sv))       sv_catpv(d, "REHASH,");
1545         if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1546         break;
1547     case SVt_PVGV:
1548     case SVt_PVLV:
1549         if (isGV_with_GP(sv)) {
1550             if (GvINTRO(sv))    sv_catpv(d, "INTRO,");
1551             if (GvMULTI(sv))    sv_catpv(d, "MULTI,");
1552             if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1553             if (GvIN_PAD(sv))   sv_catpv(d, "IN_PAD,");
1554         }
1555         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1556             sv_catpv(d, "IMPORT");
1557             if (GvIMPORTED(sv) == GVf_IMPORTED)
1558                 sv_catpv(d, "ALL,");
1559             else {
1560                 sv_catpv(d, "(");
1561                 if (GvIMPORTED_SV(sv))  sv_catpv(d, " SV");
1562                 if (GvIMPORTED_AV(sv))  sv_catpv(d, " AV");
1563                 if (GvIMPORTED_HV(sv))  sv_catpv(d, " HV");
1564                 if (GvIMPORTED_CV(sv))  sv_catpv(d, " CV");
1565                 sv_catpv(d, " ),");
1566             }
1567         }
1568         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1569         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1570         /* FALL THROUGH */
1571     default:
1572     evaled_or_uv:
1573         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1574         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1575         break;
1576     case SVt_PVMG:
1577         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1578         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1579         /* FALL THROUGH */
1580     case SVt_PVNV:
1581         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1582         goto evaled_or_uv;
1583     case SVt_PVAV:
1584         break;
1585     }
1586     /* SVphv_SHAREKEYS is also 0x20000000 */
1587     if ((type != SVt_PVHV) && SvUTF8(sv))
1588         sv_catpv(d, "UTF8");
1589
1590     if (*(SvEND(d) - 1) == ',') {
1591         SvCUR_set(d, SvCUR(d) - 1);
1592         SvPVX(d)[SvCUR(d)] = '\0';
1593     }
1594     sv_catpv(d, ")");
1595     s = SvPVX_const(d);
1596
1597 #ifdef DEBUG_LEAKING_SCALARS
1598     Perl_dump_indent(aTHX_ level, file,
1599         "ALLOCATED at %s:%d %s %s%s; serial %"UVuf"\n",
1600         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1601         sv->sv_debug_line,
1602         sv->sv_debug_inpad ? "for" : "by",
1603         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1604         sv->sv_debug_cloned ? " (cloned)" : "",
1605         sv->sv_debug_serial
1606     );
1607 #endif
1608     Perl_dump_indent(aTHX_ level, file, "SV = ");
1609     if (type < SVt_LAST) {
1610         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1611
1612         if (type ==  SVt_NULL) {
1613             SvREFCNT_dec(d);
1614             return;
1615         }
1616     } else {
1617         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1618         SvREFCNT_dec(d);
1619         return;
1620     }
1621     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1622          && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM
1623          && type != SVt_PVIO && type != SVt_REGEXP)
1624         || (type == SVt_IV && !SvROK(sv))) {
1625         if (SvIsUV(sv)
1626 #ifdef PERL_OLD_COPY_ON_WRITE
1627                        || SvIsCOW(sv)
1628 #endif
1629                                      )
1630             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1631         else
1632             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1633 #ifdef PERL_OLD_COPY_ON_WRITE
1634         if (SvIsCOW_shared_hash(sv))
1635             PerlIO_printf(file, "  (HASH)");
1636         else if (SvIsCOW_normal(sv))
1637             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1638 #endif
1639         PerlIO_putc(file, '\n');
1640     }
1641     if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1642         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1643                          (UV) COP_SEQ_RANGE_LOW(sv));
1644         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1645                          (UV) COP_SEQ_RANGE_HIGH(sv));
1646     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1647                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1648                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1649                || type == SVt_NV) {
1650         STORE_NUMERIC_LOCAL_SET_STANDARD();
1651         /* %Vg doesn't work? --jhi */
1652 #ifdef USE_LONG_DOUBLE
1653         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1654 #else
1655         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1656 #endif
1657         RESTORE_NUMERIC_LOCAL();
1658     }
1659     if (SvROK(sv)) {
1660         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1661         if (nest < maxnest)
1662             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1663     }
1664     if (type < SVt_PV) {
1665         SvREFCNT_dec(d);
1666         return;
1667     }
1668     if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1669         if (SvPVX_const(sv)) {
1670             STRLEN delta;
1671             if (SvOOK(sv)) {
1672                 SvOOK_offset(sv, delta);
1673                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1674                                  (UV) delta);
1675             } else {
1676                 delta = 0;
1677             }
1678             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1679             if (SvOOK(sv)) {
1680                 PerlIO_printf(file, "( %s . ) ",
1681                               pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1682                                          pvlim));
1683             }
1684             PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1685             if (SvUTF8(sv)) /* the 6?  \x{....} */
1686                 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1687             PerlIO_printf(file, "\n");
1688             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1689             Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
1690         }
1691         else
1692             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1693     }
1694     if (type == SVt_REGEXP) {
1695         /* FIXME dumping
1696             Perl_dump_indent(aTHX_ level, file, "  REGEXP = 0x%"UVxf"\n",
1697                              PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1698         */
1699     }
1700     if (type >= SVt_PVMG) {
1701         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1702             HV * const ost = SvOURSTASH(sv);
1703             if (ost)
1704                 do_hv_dump(level, file, "  OURSTASH", ost);
1705         } else {
1706             if (SvMAGIC(sv))
1707                 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1708         }
1709         if (SvSTASH(sv))
1710             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1711     }
1712     switch (type) {
1713     case SVt_PVAV:
1714         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1715         if (AvARRAY(sv) != AvALLOC(sv)) {
1716             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1717             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1718         }
1719         else
1720             PerlIO_putc(file, '\n');
1721         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1722         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1723         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1724         sv_setpvs(d, "");
1725         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1726         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1727         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1728                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1729         if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1730             int count;
1731             for (count = 0; count <=  av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1732                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1733
1734                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1735                 if (elt)
1736                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1737             }
1738         }
1739         break;
1740     case SVt_PVHV:
1741         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1742         if (HvARRAY(sv) && HvKEYS(sv)) {
1743             /* Show distribution of HEs in the ARRAY */
1744             int freq[200];
1745 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1746             int i;
1747             int max = 0;
1748             U32 pow2 = 2, keys = HvKEYS(sv);
1749             NV theoret, sum = 0;
1750
1751             PerlIO_printf(file, "  (");
1752             Zero(freq, FREQ_MAX + 1, int);
1753             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1754                 HE* h;
1755                 int count = 0;
1756                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1757                     count++;
1758                 if (count > FREQ_MAX)
1759                     count = FREQ_MAX;
1760                 freq[count]++;
1761                 if (max < count)
1762                     max = count;
1763             }
1764             for (i = 0; i <= max; i++) {
1765                 if (freq[i]) {
1766                     PerlIO_printf(file, "%d%s:%d", i,
1767                                   (i == FREQ_MAX) ? "+" : "",
1768                                   freq[i]);
1769                     if (i != max)
1770                         PerlIO_printf(file, ", ");
1771                 }
1772             }
1773             PerlIO_putc(file, ')');
1774             /* The "quality" of a hash is defined as the total number of
1775                comparisons needed to access every element once, relative
1776                to the expected number needed for a random hash.
1777
1778                The total number of comparisons is equal to the sum of
1779                the squares of the number of entries in each bucket.
1780                For a random hash of n keys into k buckets, the expected
1781                value is
1782                                 n + n(n-1)/2k
1783             */
1784
1785             for (i = max; i > 0; i--) { /* Precision: count down. */
1786                 sum += freq[i] * i * i;
1787             }
1788             while ((keys = keys >> 1))
1789                 pow2 = pow2 << 1;
1790             theoret = HvKEYS(sv);
1791             theoret += theoret * (theoret-1)/pow2;
1792             PerlIO_putc(file, '\n');
1793             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1794         }
1795         PerlIO_putc(file, '\n');
1796         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1797         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1798         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1799         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1800         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1801         {
1802             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1803             if (mg && mg->mg_obj) {
1804                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1805             }
1806         }
1807         {
1808             const char * const hvname = HvNAME_get(sv);
1809             if (hvname)
1810                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1811         }
1812         if (SvOOK(sv)) {
1813             AV * const backrefs
1814                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1815             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1816             if (backrefs) {
1817                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1818                                  PTR2UV(backrefs));
1819                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1820                            dumpops, pvlim);
1821             }
1822             if (meta) {
1823                 /* FIXME - mro_algs kflags can signal a UTF-8 name.  */
1824                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1825                                  (int)meta->mro_which->length,
1826                                  meta->mro_which->name,
1827                                  PTR2UV(meta->mro_which));
1828                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1829                                  (UV)meta->cache_gen);
1830                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1831                                  (UV)meta->pkg_gen);
1832                 if (meta->mro_linear_all) {
1833                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1834                                  PTR2UV(meta->mro_linear_all));
1835                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1836                            dumpops, pvlim);
1837                 }
1838                 if (meta->mro_linear_current) {
1839                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1840                                  PTR2UV(meta->mro_linear_current));
1841                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1842                            dumpops, pvlim);
1843                 }
1844                 if (meta->mro_nextmethod) {
1845                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1846                                  PTR2UV(meta->mro_nextmethod));
1847                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1848                            dumpops, pvlim);
1849                 }
1850                 if (meta->isa) {
1851                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1852                                  PTR2UV(meta->isa));
1853                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1854                            dumpops, pvlim);
1855                 }
1856             }
1857         }
1858         if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1859             HE *he;
1860             HV * const hv = MUTABLE_HV(sv);
1861             int count = maxnest - nest;
1862
1863             hv_iterinit(hv);
1864             while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1865                    && count--) {
1866                 STRLEN len;
1867                 const U32 hash = HeHASH(he);
1868                 SV * const keysv = hv_iterkeysv(he);
1869                 const char * const keypv = SvPV_const(keysv, len);
1870                 SV * const elt = hv_iterval(hv, he);
1871
1872                 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1873                 if (SvUTF8(keysv))
1874                     PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1875                 if (HeKREHASH(he))
1876                     PerlIO_printf(file, "[REHASH] ");
1877                 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1878                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1879             }
1880             hv_iterinit(hv);            /* Return to status quo */
1881         }
1882         break;
1883     case SVt_PVCV:
1884         if (SvPOK(sv)) {
1885             STRLEN len;
1886             const char *const proto =  SvPV_const(sv, len);
1887             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1888                              (int) len, proto);
1889         }
1890         /* FALL THROUGH */
1891     case SVt_PVFM:
1892         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1893         if (!CvISXSUB(sv)) {
1894             if (CvSTART(sv)) {
1895                 Perl_dump_indent(aTHX_ level, file,
1896                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1897                                  PTR2UV(CvSTART(sv)),
1898                                  (IV)sequence_num(CvSTART(sv)));
1899             }
1900             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1901                              PTR2UV(CvROOT(sv)));
1902             if (CvROOT(sv) && dumpops) {
1903                 do_op_dump(level+1, file, CvROOT(sv));
1904             }
1905         } else {
1906             SV * const constant = cv_const_sv((const CV *)sv);
1907
1908             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1909
1910             if (constant) {
1911                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1912                                  " (CONST SV)\n",
1913                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1914                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1915                            pvlim);
1916             } else {
1917                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1918                                  (IV)CvXSUBANY(sv).any_i32);
1919             }
1920         }
1921         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1922         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1923         if (type == SVt_PVCV)
1924             Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1925         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1926         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1927         if (type == SVt_PVFM)
1928             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
1929         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1930         if (nest < maxnest) {
1931             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1932         }
1933         {
1934             const CV * const outside = CvOUTSIDE(sv);
1935             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1936                         PTR2UV(outside),
1937                         (!outside ? "null"
1938                          : CvANON(outside) ? "ANON"
1939                          : (outside == PL_main_cv) ? "MAIN"
1940                          : CvUNIQUE(outside) ? "UNIQUE"
1941                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1942         }
1943         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1944             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1945         break;
1946     case SVt_PVGV:
1947     case SVt_PVLV:
1948         if (type == SVt_PVLV) {
1949             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
1950             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1951             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1952             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1953             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1954                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1955                     dumpops, pvlim);
1956         }
1957         if (SvVALID(sv)) {
1958             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %u\n", (U8)BmFLAGS(sv));
1959             Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
1960             Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1961             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1962         }
1963         if (!isGV_with_GP(sv))
1964             break;
1965         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
1966         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1967         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
1968         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1969         if (!GvGP(sv))
1970             break;
1971         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1972         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1973         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1974         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
1975         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1976         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1977         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1978         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1979         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
1980         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
1981         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1982         do_gv_dump (level, file, "    EGV", GvEGV(sv));
1983         break;
1984     case SVt_PVIO:
1985         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1986         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1987         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1988         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
1989         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1990         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1991         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1992         if (IoTOP_NAME(sv))
1993             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1994         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1995             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
1996         else {
1997             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
1998                              PTR2UV(IoTOP_GV(sv)));
1999             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2000                         maxnest, dumpops, pvlim);
2001         }
2002         /* Source filters hide things that are not GVs in these three, so let's
2003            be careful out there.  */
2004         if (IoFMT_NAME(sv))
2005             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2006         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2007             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2008         else {
2009             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2010                              PTR2UV(IoFMT_GV(sv)));
2011             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2012                         maxnest, dumpops, pvlim);
2013         }
2014         if (IoBOTTOM_NAME(sv))
2015             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2016         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2017             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2018         else {
2019             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2020                              PTR2UV(IoBOTTOM_GV(sv)));
2021             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2022                         maxnest, dumpops, pvlim);
2023         }
2024         if (isPRINT(IoTYPE(sv)))
2025             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2026         else
2027             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2028         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2029         break;
2030     }
2031     SvREFCNT_dec(d);
2032 }
2033
2034 void
2035 Perl_sv_dump(pTHX_ SV *sv)
2036 {
2037     dVAR;
2038
2039     PERL_ARGS_ASSERT_SV_DUMP;
2040
2041     if (SvROK(sv))
2042         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2043     else
2044         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2045 }
2046
2047 int
2048 Perl_runops_debug(pTHX)
2049 {
2050     dVAR;
2051     if (!PL_op) {
2052         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2053         return 0;
2054     }
2055
2056     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2057     do {
2058         if (PL_debug) {
2059             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2060                 PerlIO_printf(Perl_debug_log,
2061                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2062                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2063                               PTR2UV(*PL_watchaddr));
2064             if (DEBUG_s_TEST_) {
2065                 if (DEBUG_v_TEST_) {
2066                     PerlIO_printf(Perl_debug_log, "\n");
2067                     deb_stack_all();
2068                 }
2069                 else
2070                     debstack();
2071             }
2072
2073
2074             if (DEBUG_t_TEST_) debop(PL_op);
2075             if (DEBUG_P_TEST_) debprof(PL_op);
2076         }
2077     } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2078     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2079
2080     TAINT_NOT;
2081     return 0;
2082 }
2083
2084 I32
2085 Perl_debop(pTHX_ const OP *o)
2086 {
2087     dVAR;
2088
2089     PERL_ARGS_ASSERT_DEBOP;
2090
2091     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2092         return 0;
2093
2094     Perl_deb(aTHX_ "%s", OP_NAME(o));
2095     switch (o->op_type) {
2096     case OP_CONST:
2097     case OP_HINTSEVAL:
2098         /* With ITHREADS, consts are stored in the pad, and the right pad
2099          * may not be active here, so check.
2100          * Looks like only during compiling the pads are illegal.
2101          */
2102 #ifdef USE_ITHREADS
2103         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2104 #endif
2105             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2106         break;
2107     case OP_GVSV:
2108     case OP_GV:
2109         if (cGVOPo_gv) {
2110             SV * const sv = newSV(0);
2111 #ifdef PERL_MAD
2112             /* FIXME - is this making unwarranted assumptions about the
2113                UTF-8 cleanliness of the dump file handle?  */
2114             SvUTF8_on(sv);
2115 #endif
2116             gv_fullname3(sv, cGVOPo_gv, NULL);
2117             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2118             SvREFCNT_dec(sv);
2119         }
2120         else
2121             PerlIO_printf(Perl_debug_log, "(NULL)");
2122         break;
2123     case OP_PADSV:
2124     case OP_PADAV:
2125     case OP_PADHV:
2126         {
2127         /* print the lexical's name */
2128         CV * const cv = deb_curcv(cxstack_ix);
2129         SV *sv;
2130         if (cv) {
2131             AV * const padlist = CvPADLIST(cv);
2132             AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2133             sv = *av_fetch(comppad, o->op_targ, FALSE);
2134         } else
2135             sv = NULL;
2136         if (sv)
2137             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2138         else
2139             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2140         }
2141         break;
2142     default:
2143         break;
2144     }
2145     PerlIO_printf(Perl_debug_log, "\n");
2146     return 0;
2147 }
2148
2149 STATIC CV*
2150 S_deb_curcv(pTHX_ const I32 ix)
2151 {
2152     dVAR;
2153     const PERL_CONTEXT * const cx = &cxstack[ix];
2154     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2155         return cx->blk_sub.cv;
2156     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2157         return PL_compcv;
2158     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2159         return PL_main_cv;
2160     else if (ix <= 0)
2161         return NULL;
2162     else
2163         return deb_curcv(ix - 1);
2164 }
2165
2166 void
2167 Perl_watch(pTHX_ char **addr)
2168 {
2169     dVAR;
2170
2171     PERL_ARGS_ASSERT_WATCH;
2172
2173     PL_watchaddr = addr;
2174     PL_watchok = *addr;
2175     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2176         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2177 }
2178
2179 STATIC void
2180 S_debprof(pTHX_ const OP *o)
2181 {
2182     dVAR;
2183
2184     PERL_ARGS_ASSERT_DEBPROF;
2185
2186     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2187         return;
2188     if (!PL_profiledata)
2189         Newxz(PL_profiledata, MAXO, U32);
2190     ++PL_profiledata[o->op_type];
2191 }
2192
2193 void
2194 Perl_debprofdump(pTHX)
2195 {
2196     dVAR;
2197     unsigned i;
2198     if (!PL_profiledata)
2199         return;
2200     for (i = 0; i < MAXO; i++) {
2201         if (PL_profiledata[i])
2202             PerlIO_printf(Perl_debug_log,
2203                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2204                                        PL_op_name[i]);
2205     }
2206 }
2207
2208 #ifdef PERL_MAD
2209 /*
2210  *    XML variants of most of the above routines
2211  */
2212
2213 STATIC void
2214 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2215 {
2216     va_list args;
2217
2218     PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2219
2220     PerlIO_printf(file, "\n    ");
2221     va_start(args, pat);
2222     xmldump_vindent(level, file, pat, &args);
2223     va_end(args);
2224 }
2225
2226
2227 void
2228 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2229 {
2230     va_list args;
2231     PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2232     va_start(args, pat);
2233     xmldump_vindent(level, file, pat, &args);
2234     va_end(args);
2235 }
2236
2237 void
2238 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2239 {
2240     PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2241
2242     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2243     PerlIO_vprintf(file, pat, *args);
2244 }
2245
2246 void
2247 Perl_xmldump_all(pTHX)
2248 {
2249     xmldump_all_perl(FALSE);
2250 }
2251
2252 void
2253 Perl_xmldump_all_perl(pTHX_ bool justperl)
2254 {
2255     PerlIO_setlinebuf(PL_xmlfp);
2256     if (PL_main_root)
2257         op_xmldump(PL_main_root);
2258     xmldump_packsubs_perl(PL_defstash, justperl);
2259     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2260         PerlIO_close(PL_xmlfp);
2261     PL_xmlfp = 0;
2262 }
2263
2264 void
2265 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2266 {
2267     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2268     xmldump_packsubs_perl(stash, FALSE);
2269 }
2270
2271 void
2272 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2273 {
2274     I32 i;
2275     HE  *entry;
2276
2277     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2278
2279     if (!HvARRAY(stash))
2280         return;
2281     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2282         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2283             GV *gv = MUTABLE_GV(HeVAL(entry));
2284             HV *hv;
2285             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2286                 continue;
2287             if (GvCVu(gv))
2288                 xmldump_sub_perl(gv, justperl);
2289             if (GvFORM(gv))
2290                 xmldump_form(gv);
2291             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2292                 && (hv = GvHV(gv)) && hv != PL_defstash)
2293                 xmldump_packsubs_perl(hv, justperl);    /* nested package */
2294         }
2295     }
2296 }
2297
2298 void
2299 Perl_xmldump_sub(pTHX_ const GV *gv)
2300 {
2301     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2302     xmldump_sub_perl(gv, FALSE);
2303 }
2304
2305 void
2306 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2307 {
2308     SV * sv;
2309
2310     PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2311
2312     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2313         return;
2314
2315     sv = sv_newmortal();
2316     gv_fullname3(sv, gv, NULL);
2317     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2318     if (CvXSUB(GvCV(gv)))
2319         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2320             PTR2UV(CvXSUB(GvCV(gv))),
2321             (int)CvXSUBANY(GvCV(gv)).any_i32);
2322     else if (CvROOT(GvCV(gv)))
2323         op_xmldump(CvROOT(GvCV(gv)));
2324     else
2325         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2326 }
2327
2328 void
2329 Perl_xmldump_form(pTHX_ const GV *gv)
2330 {
2331     SV * const sv = sv_newmortal();
2332
2333     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2334
2335     gv_fullname3(sv, gv, NULL);
2336     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2337     if (CvROOT(GvFORM(gv)))
2338         op_xmldump(CvROOT(GvFORM(gv)));
2339     else
2340         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2341 }
2342
2343 void
2344 Perl_xmldump_eval(pTHX)
2345 {
2346     op_xmldump(PL_eval_root);
2347 }
2348
2349 char *
2350 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2351 {
2352     PERL_ARGS_ASSERT_SV_CATXMLSV;
2353     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2354 }
2355
2356 char *
2357 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2358 {
2359     unsigned int c;
2360     const char * const e = pv + len;
2361     const char * const start = pv;
2362     STRLEN dsvcur;
2363     STRLEN cl;
2364
2365     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2366
2367     sv_catpvs(dsv,"");
2368     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2369
2370   retry:
2371     while (pv < e) {
2372         if (utf8) {
2373             c = utf8_to_uvchr((U8*)pv, &cl);
2374             if (cl == 0) {
2375                 SvCUR(dsv) = dsvcur;
2376                 pv = start;
2377                 utf8 = 0;
2378                 goto retry;
2379             }
2380         }
2381         else
2382             c = (*pv & 255);
2383
2384         switch (c) {
2385         case 0x00:
2386         case 0x01:
2387         case 0x02:
2388         case 0x03:
2389         case 0x04:
2390         case 0x05:
2391         case 0x06:
2392         case 0x07:
2393         case 0x08:
2394         case 0x0b:
2395         case 0x0c:
2396         case 0x0e:
2397         case 0x0f:
2398         case 0x10:
2399         case 0x11:
2400         case 0x12:
2401         case 0x13:
2402         case 0x14:
2403         case 0x15:
2404         case 0x16:
2405         case 0x17:
2406         case 0x18:
2407         case 0x19:
2408         case 0x1a:
2409         case 0x1b:
2410         case 0x1c:
2411         case 0x1d:
2412         case 0x1e:
2413         case 0x1f:
2414         case 0x7f:
2415         case 0x80:
2416         case 0x81:
2417         case 0x82:
2418         case 0x83:
2419         case 0x84:
2420         case 0x86:
2421         case 0x87:
2422         case 0x88:
2423         case 0x89:
2424         case 0x90:
2425         case 0x91:
2426         case 0x92:
2427         case 0x93:
2428         case 0x94:
2429         case 0x95:
2430         case 0x96:
2431         case 0x97:
2432         case 0x98:
2433         case 0x99:
2434         case 0x9a:
2435         case 0x9b:
2436         case 0x9c:
2437         case 0x9d:
2438         case 0x9e:
2439         case 0x9f:
2440             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2441             break;
2442         case '<':
2443             sv_catpvs(dsv, "&lt;");
2444             break;
2445         case '>':
2446             sv_catpvs(dsv, "&gt;");
2447             break;
2448         case '&':
2449             sv_catpvs(dsv, "&amp;");
2450             break;
2451         case '"':
2452             sv_catpvs(dsv, "&#34;");
2453             break;
2454         default:
2455             if (c < 0xD800) {
2456                 if (c < 32 || c > 127) {
2457                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2458                 }
2459                 else {
2460                     const char string = (char) c;
2461                     sv_catpvn(dsv, &string, 1);
2462                 }
2463                 break;
2464             }
2465             if ((c >= 0xD800 && c <= 0xDB7F) ||
2466                 (c >= 0xDC00 && c <= 0xDFFF) ||
2467                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2468                  c > 0x10ffff)
2469                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2470             else
2471                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2472         }
2473
2474         if (utf8)
2475             pv += UTF8SKIP(pv);
2476         else
2477             pv++;
2478     }
2479
2480     return SvPVX(dsv);
2481 }
2482
2483 char *
2484 Perl_sv_xmlpeek(pTHX_ SV *sv)
2485 {
2486     SV * const t = sv_newmortal();
2487     STRLEN n_a;
2488     int unref = 0;
2489
2490     PERL_ARGS_ASSERT_SV_XMLPEEK;
2491
2492     sv_utf8_upgrade(t);
2493     sv_setpvs(t, "");
2494     /* retry: */
2495     if (!sv) {
2496         sv_catpv(t, "VOID=\"\"");
2497         goto finish;
2498     }
2499     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2500         sv_catpv(t, "WILD=\"\"");
2501         goto finish;
2502     }
2503     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2504         if (sv == &PL_sv_undef) {
2505             sv_catpv(t, "SV_UNDEF=\"1\"");
2506             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2507                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2508                 SvREADONLY(sv))
2509                 goto finish;
2510         }
2511         else if (sv == &PL_sv_no) {
2512             sv_catpv(t, "SV_NO=\"1\"");
2513             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2514                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2515                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2516                                   SVp_POK|SVp_NOK)) &&
2517                 SvCUR(sv) == 0 &&
2518                 SvNVX(sv) == 0.0)
2519                 goto finish;
2520         }
2521         else if (sv == &PL_sv_yes) {
2522             sv_catpv(t, "SV_YES=\"1\"");
2523             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2524                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2525                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2526                                   SVp_POK|SVp_NOK)) &&
2527                 SvCUR(sv) == 1 &&
2528                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2529                 SvNVX(sv) == 1.0)
2530                 goto finish;
2531         }
2532         else {
2533             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2534             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2535                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2536                 SvREADONLY(sv))
2537                 goto finish;
2538         }
2539         sv_catpv(t, " XXX=\"\" ");
2540     }
2541     else if (SvREFCNT(sv) == 0) {
2542         sv_catpv(t, " refcnt=\"0\"");
2543         unref++;
2544     }
2545     else if (DEBUG_R_TEST_) {
2546         int is_tmp = 0;
2547         I32 ix;
2548         /* is this SV on the tmps stack? */
2549         for (ix=PL_tmps_ix; ix>=0; ix--) {
2550             if (PL_tmps_stack[ix] == sv) {
2551                 is_tmp = 1;
2552                 break;
2553             }
2554         }
2555         if (SvREFCNT(sv) > 1)
2556             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2557                     is_tmp ? "T" : "");
2558         else if (is_tmp)
2559             sv_catpv(t, " DRT=\"<T>\"");
2560     }
2561
2562     if (SvROK(sv)) {
2563         sv_catpv(t, " ROK=\"\"");
2564     }
2565     switch (SvTYPE(sv)) {
2566     default:
2567         sv_catpv(t, " FREED=\"1\"");
2568         goto finish;
2569
2570     case SVt_NULL:
2571         sv_catpv(t, " UNDEF=\"1\"");
2572         goto finish;
2573     case SVt_IV:
2574         sv_catpv(t, " IV=\"");
2575         break;
2576     case SVt_NV:
2577         sv_catpv(t, " NV=\"");
2578         break;
2579     case SVt_PV:
2580         sv_catpv(t, " PV=\"");
2581         break;
2582     case SVt_PVIV:
2583         sv_catpv(t, " PVIV=\"");
2584         break;
2585     case SVt_PVNV:
2586         sv_catpv(t, " PVNV=\"");
2587         break;
2588     case SVt_PVMG:
2589         sv_catpv(t, " PVMG=\"");
2590         break;
2591     case SVt_PVLV:
2592         sv_catpv(t, " PVLV=\"");
2593         break;
2594     case SVt_PVAV:
2595         sv_catpv(t, " AV=\"");
2596         break;
2597     case SVt_PVHV:
2598         sv_catpv(t, " HV=\"");
2599         break;
2600     case SVt_PVCV:
2601         if (CvGV(sv))
2602             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2603         else
2604             sv_catpv(t, " CV=\"()\"");
2605         goto finish;
2606     case SVt_PVGV:
2607         sv_catpv(t, " GV=\"");
2608         break;
2609     case SVt_BIND:
2610         sv_catpv(t, " BIND=\"");
2611         break;
2612     case SVt_REGEXP:
2613         sv_catpv(t, " ORANGE=\"");
2614         break;
2615     case SVt_PVFM:
2616         sv_catpv(t, " FM=\"");
2617         break;
2618     case SVt_PVIO:
2619         sv_catpv(t, " IO=\"");
2620         break;
2621     }
2622
2623     if (SvPOKp(sv)) {
2624         if (SvPVX(sv)) {
2625             sv_catxmlsv(t, sv);
2626         }
2627     }
2628     else if (SvNOKp(sv)) {
2629         STORE_NUMERIC_LOCAL_SET_STANDARD();
2630         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2631         RESTORE_NUMERIC_LOCAL();
2632     }
2633     else if (SvIOKp(sv)) {
2634         if (SvIsUV(sv))
2635             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2636         else
2637             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2638     }
2639     else
2640         sv_catpv(t, "");
2641     sv_catpv(t, "\"");
2642
2643   finish:
2644     while (unref--)
2645         sv_catpv(t, ")");
2646     return SvPV(t, n_a);
2647 }
2648
2649 void
2650 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2651 {
2652     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2653
2654     if (!pm) {
2655         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2656         return;
2657     }
2658     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2659     level++;
2660     if (PM_GETRE(pm)) {
2661         REGEXP *const r = PM_GETRE(pm);
2662         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2663         sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2664         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2665              SvPVX(tmpsv));
2666         SvREFCNT_dec(tmpsv);
2667         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2668              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2669     }
2670     else
2671         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2672     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2673         SV * const tmpsv = pm_description(pm);
2674         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2675         SvREFCNT_dec(tmpsv);
2676     }
2677
2678     level--;
2679     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2680         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2681         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2682         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2683         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2684         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2685     }
2686     else
2687         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2688 }
2689
2690 void
2691 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2692 {
2693     do_pmop_xmldump(0, PL_xmlfp, pm);
2694 }
2695
2696 void
2697 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2698 {
2699     UV      seq;
2700     int     contents = 0;
2701
2702     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2703
2704     if (!o)
2705         return;
2706     sequence(o);
2707     seq = sequence_num(o);
2708     Perl_xmldump_indent(aTHX_ level, file,
2709         "<op_%s seq=\"%"UVuf" -> ",
2710              OP_NAME(o),
2711                       seq);
2712     level++;
2713     if (o->op_next)
2714         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2715                       sequence_num(o->op_next));
2716     else
2717         PerlIO_printf(file, "DONE\"");
2718
2719     if (o->op_targ) {
2720         if (o->op_type == OP_NULL)
2721         {
2722             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2723             if (o->op_targ == OP_NEXTSTATE)
2724             {
2725                 if (CopLINE(cCOPo))
2726                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2727                                      (UV)CopLINE(cCOPo));
2728                 if (CopSTASHPV(cCOPo))
2729                     PerlIO_printf(file, " package=\"%s\"",
2730                                      CopSTASHPV(cCOPo));
2731                 if (CopLABEL(cCOPo))
2732                     PerlIO_printf(file, " label=\"%s\"",
2733                                      CopLABEL(cCOPo));
2734             }
2735         }
2736         else
2737             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2738     }
2739 #ifdef DUMPADDR
2740     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2741 #endif
2742     if (o->op_flags) {
2743         SV * const tmpsv = newSVpvs("");
2744         switch (o->op_flags & OPf_WANT) {
2745         case OPf_WANT_VOID:
2746             sv_catpv(tmpsv, ",VOID");
2747             break;
2748         case OPf_WANT_SCALAR:
2749             sv_catpv(tmpsv, ",SCALAR");
2750             break;
2751         case OPf_WANT_LIST:
2752             sv_catpv(tmpsv, ",LIST");
2753             break;
2754         default:
2755             sv_catpv(tmpsv, ",UNKNOWN");
2756             break;
2757         }
2758         if (o->op_flags & OPf_KIDS)
2759             sv_catpv(tmpsv, ",KIDS");
2760         if (o->op_flags & OPf_PARENS)
2761             sv_catpv(tmpsv, ",PARENS");
2762         if (o->op_flags & OPf_STACKED)
2763             sv_catpv(tmpsv, ",STACKED");
2764         if (o->op_flags & OPf_REF)
2765             sv_catpv(tmpsv, ",REF");
2766         if (o->op_flags & OPf_MOD)
2767             sv_catpv(tmpsv, ",MOD");
2768         if (o->op_flags & OPf_SPECIAL)
2769             sv_catpv(tmpsv, ",SPECIAL");
2770         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2771         SvREFCNT_dec(tmpsv);
2772     }
2773     if (o->op_private) {
2774         SV * const tmpsv = newSVpvs("");
2775         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2776             if (o->op_private & OPpTARGET_MY)
2777                 sv_catpv(tmpsv, ",TARGET_MY");
2778         }
2779         else if (o->op_type == OP_LEAVESUB ||
2780                  o->op_type == OP_LEAVE ||
2781                  o->op_type == OP_LEAVESUBLV ||
2782                  o->op_type == OP_LEAVEWRITE) {
2783             if (o->op_private & OPpREFCOUNTED)
2784                 sv_catpv(tmpsv, ",REFCOUNTED");
2785         }
2786         else if (o->op_type == OP_AASSIGN) {
2787             if (o->op_private & OPpASSIGN_COMMON)
2788                 sv_catpv(tmpsv, ",COMMON");
2789         }
2790         else if (o->op_type == OP_SASSIGN) {
2791             if (o->op_private & OPpASSIGN_BACKWARDS)
2792                 sv_catpv(tmpsv, ",BACKWARDS");
2793         }
2794         else if (o->op_type == OP_TRANS) {
2795             if (o->op_private & OPpTRANS_SQUASH)
2796                 sv_catpv(tmpsv, ",SQUASH");
2797             if (o->op_private & OPpTRANS_DELETE)
2798                 sv_catpv(tmpsv, ",DELETE");
2799             if (o->op_private & OPpTRANS_COMPLEMENT)
2800                 sv_catpv(tmpsv, ",COMPLEMENT");
2801             if (o->op_private & OPpTRANS_IDENTICAL)
2802                 sv_catpv(tmpsv, ",IDENTICAL");
2803             if (o->op_private & OPpTRANS_GROWS)
2804                 sv_catpv(tmpsv, ",GROWS");
2805         }
2806         else if (o->op_type == OP_REPEAT) {
2807             if (o->op_private & OPpREPEAT_DOLIST)
2808                 sv_catpv(tmpsv, ",DOLIST");
2809         }
2810         else if (o->op_type == OP_ENTERSUB ||
2811                  o->op_type == OP_RV2SV ||
2812                  o->op_type == OP_GVSV ||
2813                  o->op_type == OP_RV2AV ||
2814                  o->op_type == OP_RV2HV ||
2815                  o->op_type == OP_RV2GV ||
2816                  o->op_type == OP_AELEM ||
2817                  o->op_type == OP_HELEM )
2818         {
2819             if (o->op_type == OP_ENTERSUB) {
2820                 if (o->op_private & OPpENTERSUB_AMPER)
2821                     sv_catpv(tmpsv, ",AMPER");
2822                 if (o->op_private & OPpENTERSUB_DB)
2823                     sv_catpv(tmpsv, ",DB");
2824                 if (o->op_private & OPpENTERSUB_HASTARG)
2825                     sv_catpv(tmpsv, ",HASTARG");
2826                 if (o->op_private & OPpENTERSUB_NOPAREN)
2827                     sv_catpv(tmpsv, ",NOPAREN");
2828                 if (o->op_private & OPpENTERSUB_INARGS)
2829                     sv_catpv(tmpsv, ",INARGS");
2830                 if (o->op_private & OPpENTERSUB_NOMOD)
2831                     sv_catpv(tmpsv, ",NOMOD");
2832             }
2833             else {
2834                 switch (o->op_private & OPpDEREF) {
2835             case OPpDEREF_SV:
2836                 sv_catpv(tmpsv, ",SV");
2837                 break;
2838             case OPpDEREF_AV:
2839                 sv_catpv(tmpsv, ",AV");
2840                 break;
2841             case OPpDEREF_HV:
2842                 sv_catpv(tmpsv, ",HV");
2843                 break;
2844             }
2845                 if (o->op_private & OPpMAYBE_LVSUB)
2846                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2847             }
2848             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2849                 if (o->op_private & OPpLVAL_DEFER)
2850                     sv_catpv(tmpsv, ",LVAL_DEFER");
2851             }
2852             else {
2853                 if (o->op_private & HINT_STRICT_REFS)
2854                     sv_catpv(tmpsv, ",STRICT_REFS");
2855                 if (o->op_private & OPpOUR_INTRO)
2856                     sv_catpv(tmpsv, ",OUR_INTRO");
2857             }
2858         }
2859         else if (o->op_type == OP_CONST) {
2860             if (o->op_private & OPpCONST_BARE)
2861                 sv_catpv(tmpsv, ",BARE");
2862             if (o->op_private & OPpCONST_STRICT)
2863                 sv_catpv(tmpsv, ",STRICT");
2864             if (o->op_private & OPpCONST_ARYBASE)
2865                 sv_catpv(tmpsv, ",ARYBASE");
2866             if (o->op_private & OPpCONST_WARNING)
2867                 sv_catpv(tmpsv, ",WARNING");
2868             if (o->op_private & OPpCONST_ENTERED)
2869                 sv_catpv(tmpsv, ",ENTERED");
2870         }
2871         else if (o->op_type == OP_FLIP) {
2872             if (o->op_private & OPpFLIP_LINENUM)
2873                 sv_catpv(tmpsv, ",LINENUM");
2874         }
2875         else if (o->op_type == OP_FLOP) {
2876             if (o->op_private & OPpFLIP_LINENUM)
2877                 sv_catpv(tmpsv, ",LINENUM");
2878         }
2879         else if (o->op_type == OP_RV2CV) {
2880             if (o->op_private & OPpLVAL_INTRO)
2881                 sv_catpv(tmpsv, ",INTRO");
2882         }
2883         else if (o->op_type == OP_GV) {
2884             if (o->op_private & OPpEARLY_CV)
2885                 sv_catpv(tmpsv, ",EARLY_CV");
2886         }
2887         else if (o->op_type == OP_LIST) {
2888             if (o->op_private & OPpLIST_GUESSED)
2889                 sv_catpv(tmpsv, ",GUESSED");
2890         }
2891         else if (o->op_type == OP_DELETE) {
2892             if (o->op_private & OPpSLICE)
2893                 sv_catpv(tmpsv, ",SLICE");
2894         }
2895         else if (o->op_type == OP_EXISTS) {
2896             if (o->op_private & OPpEXISTS_SUB)
2897                 sv_catpv(tmpsv, ",EXISTS_SUB");
2898         }
2899         else if (o->op_type == OP_SORT) {
2900             if (o->op_private & OPpSORT_NUMERIC)
2901                 sv_catpv(tmpsv, ",NUMERIC");
2902             if (o->op_private & OPpSORT_INTEGER)
2903                 sv_catpv(tmpsv, ",INTEGER");
2904             if (o->op_private & OPpSORT_REVERSE)
2905                 sv_catpv(tmpsv, ",REVERSE");
2906         }
2907         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2908             if (o->op_private & OPpOPEN_IN_RAW)
2909                 sv_catpv(tmpsv, ",IN_RAW");
2910             if (o->op_private & OPpOPEN_IN_CRLF)
2911                 sv_catpv(tmpsv, ",IN_CRLF");
2912             if (o->op_private & OPpOPEN_OUT_RAW)
2913                 sv_catpv(tmpsv, ",OUT_RAW");
2914             if (o->op_private & OPpOPEN_OUT_CRLF)
2915                 sv_catpv(tmpsv, ",OUT_CRLF");
2916         }
2917         else if (o->op_type == OP_EXIT) {
2918             if (o->op_private & OPpEXIT_VMSISH)
2919                 sv_catpv(tmpsv, ",EXIT_VMSISH");
2920             if (o->op_private & OPpHUSH_VMSISH)
2921                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2922         }
2923         else if (o->op_type == OP_DIE) {
2924             if (o->op_private & OPpHUSH_VMSISH)
2925                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2926         }
2927         else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2928             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2929                 sv_catpv(tmpsv, ",FT_ACCESS");
2930             if (o->op_private & OPpFT_STACKED)
2931                 sv_catpv(tmpsv, ",FT_STACKED");
2932         }
2933         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2934             sv_catpv(tmpsv, ",INTRO");
2935         if (SvCUR(tmpsv))
2936             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2937         SvREFCNT_dec(tmpsv);
2938     }
2939
2940     switch (o->op_type) {
2941     case OP_AELEMFAST:
2942         if (o->op_flags & OPf_SPECIAL) {
2943             break;
2944         }
2945     case OP_GVSV:
2946     case OP_GV:
2947 #ifdef USE_ITHREADS
2948         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2949 #else
2950         if (cSVOPo->op_sv) {
2951             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2952             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2953             char *s;
2954             STRLEN len;
2955             ENTER;
2956             SAVEFREESV(tmpsv1);
2957             SAVEFREESV(tmpsv2);
2958             gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2959             s = SvPV(tmpsv1,len);
2960             sv_catxmlpvn(tmpsv2, s, len, 1);
2961             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2962             LEAVE;
2963         }
2964         else
2965             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2966 #endif
2967         break;
2968     case OP_CONST:
2969     case OP_HINTSEVAL:
2970     case OP_METHOD_NAMED:
2971 #ifndef USE_ITHREADS
2972         /* with ITHREADS, consts are stored in the pad, and the right pad
2973          * may not be active here, so skip */
2974         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2975 #endif
2976         break;
2977     case OP_ANONCODE:
2978         if (!contents) {
2979             contents = 1;
2980             PerlIO_printf(file, ">\n");
2981         }
2982         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2983         break;
2984     case OP_NEXTSTATE:
2985     case OP_DBSTATE:
2986         if (CopLINE(cCOPo))
2987             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2988                              (UV)CopLINE(cCOPo));
2989         if (CopSTASHPV(cCOPo))
2990             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2991                              CopSTASHPV(cCOPo));
2992         if (CopLABEL(cCOPo))
2993             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2994                              CopLABEL(cCOPo));
2995         break;
2996     case OP_ENTERLOOP:
2997         S_xmldump_attr(aTHX_ level, file, "redo=\"");
2998         if (cLOOPo->op_redoop)
2999             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3000         else
3001             PerlIO_printf(file, "DONE\"");
3002         S_xmldump_attr(aTHX_ level, file, "next=\"");
3003         if (cLOOPo->op_nextop)
3004             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3005         else
3006             PerlIO_printf(file, "DONE\"");
3007         S_xmldump_attr(aTHX_ level, file, "last=\"");
3008         if (cLOOPo->op_lastop)
3009             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3010         else
3011             PerlIO_printf(file, "DONE\"");
3012         break;
3013     case OP_COND_EXPR:
3014     case OP_RANGE:
3015     case OP_MAPWHILE:
3016     case OP_GREPWHILE:
3017     case OP_OR:
3018     case OP_AND:
3019         S_xmldump_attr(aTHX_ level, file, "other=\"");
3020         if (cLOGOPo->op_other)
3021             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3022         else
3023             PerlIO_printf(file, "DONE\"");
3024         break;
3025     case OP_LEAVE:
3026     case OP_LEAVEEVAL:
3027     case OP_LEAVESUB:
3028     case OP_LEAVESUBLV:
3029     case OP_LEAVEWRITE:
3030     case OP_SCOPE:
3031         if (o->op_private & OPpREFCOUNTED)
3032             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3033         break;
3034     default:
3035         break;
3036     }
3037
3038     if (PL_madskills && o->op_madprop) {
3039         char prevkey = '\0';
3040         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3041         const MADPROP* mp = o->op_madprop;
3042
3043         if (!contents) {
3044             contents = 1;
3045             PerlIO_printf(file, ">\n");
3046         }
3047         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3048         level++;
3049         while (mp) {
3050             char tmp = mp->mad_key;
3051             sv_setpvs(tmpsv,"\"");
3052             if (tmp)
3053                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3054             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3055                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3056             else
3057                 prevkey = tmp;
3058             sv_catpv(tmpsv, "\"");
3059             switch (mp->mad_type) {
3060             case MAD_NULL:
3061                 sv_catpv(tmpsv, "NULL");
3062                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3063                 break;
3064             case MAD_PV:
3065                 sv_catpv(tmpsv, " val=\"");
3066                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3067                 sv_catpv(tmpsv, "\"");
3068                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3069                 break;
3070             case MAD_SV:
3071                 sv_catpv(tmpsv, " val=\"");
3072                 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3073                 sv_catpv(tmpsv, "\"");
3074                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3075                 break;
3076             case MAD_OP:
3077                 if ((OP*)mp->mad_val) {
3078                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3079                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3080                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3081                 }
3082                 break;
3083             default:
3084                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3085                 break;
3086             }
3087             mp = mp->mad_next;
3088         }
3089         level--;
3090         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3091
3092         SvREFCNT_dec(tmpsv);
3093     }
3094
3095     switch (o->op_type) {
3096     case OP_PUSHRE:
3097     case OP_MATCH:
3098     case OP_QR:
3099     case OP_SUBST:
3100         if (!contents) {
3101             contents = 1;
3102             PerlIO_printf(file, ">\n");
3103         }
3104         do_pmop_xmldump(level, file, cPMOPo);
3105         break;
3106     default:
3107         break;
3108     }
3109
3110     if (o->op_flags & OPf_KIDS) {
3111         OP *kid;
3112         if (!contents) {
3113             contents = 1;
3114             PerlIO_printf(file, ">\n");
3115         }
3116         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3117             do_op_xmldump(level, file, kid);
3118     }
3119
3120     if (contents)
3121         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3122     else
3123         PerlIO_printf(file, " />\n");
3124 }
3125
3126 void
3127 Perl_op_xmldump(pTHX_ const OP *o)
3128 {
3129     PERL_ARGS_ASSERT_OP_XMLDUMP;
3130
3131     do_op_xmldump(0, PL_xmlfp, o);
3132 }
3133 #endif
3134
3135 /*
3136  * Local variables:
3137  * c-indentation-style: bsd
3138  * c-basic-offset: 4
3139  * indent-tabs-mode: t
3140  * End:
3141  *
3142  * ex: set ts=8 sts=4 sw=4 noet:
3143  */