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), C_ARRAY_END(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_REF, ",REF"},
 793     {OPf_MOD, ",MOD"},
 794     {OPf_STACKED, ",STACKED"},
 795     {OPf_SPECIAL, ",SPECIAL"}
 796 };
 797
 798 const struct flag_to_name op_trans_names[] = {
 799     {OPpTRANS_FROM_UTF, ",FROM_UTF"},
 800     {OPpTRANS_TO_UTF, ",TO_UTF"},
 801     {OPpTRANS_IDENTICAL, ",IDENTICAL"},
 802     {OPpTRANS_SQUASH, ",SQUASH"},
 803     {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
 804     {OPpTRANS_GROWS, ",GROWS"},
 805     {OPpTRANS_DELETE, ",DELETE"}
 806 };
 807
 808 const struct flag_to_name op_entersub_names[] = {
 809     {OPpENTERSUB_DB, ",DB"},
 810     {OPpENTERSUB_HASTARG, ",HASTARG"},
 811     {OPpENTERSUB_NOMOD, ",NOMOD"},
 812     {OPpENTERSUB_AMPER, ",AMPER"},
 813     {OPpENTERSUB_NOPAREN, ",NOPAREN"},
 814     {OPpENTERSUB_INARGS, ",INARGS"}
 815 };
 816
 817 const struct flag_to_name op_const_names[] = {
 818     {OPpCONST_NOVER, ",NOVER"},
 819     {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
 820     {OPpCONST_STRICT, ",STRICT"},
 821     {OPpCONST_ENTERED, ",ENTERED"},
 822     {OPpCONST_ARYBASE, ",ARYBASE"},
 823     {OPpCONST_BARE, ",BARE"},
 824     {OPpCONST_WARNING, ",WARNING"}
 825 };
 826
 827 const struct flag_to_name op_sort_names[] = {
 828     {OPpSORT_NUMERIC, ",NUMERIC"},
 829     {OPpSORT_INTEGER, ",INTEGER"},
 830     {OPpSORT_REVERSE, ",REVERSE"},
 831     {OPpSORT_INPLACE, ",INPLACE"},
 832     {OPpSORT_DESCEND, ",DESCEND"},
 833     {OPpSORT_QSORT, ",QSORT"},
 834     {OPpSORT_STABLE, ",STABLE"}
 835 };
 836
 837 const struct flag_to_name op_open_names[] = {
 838     {OPpOPEN_IN_RAW, ",IN_RAW"},
 839     {OPpOPEN_IN_CRLF, ",IN_CRLF"},
 840     {OPpOPEN_OUT_RAW, ",OUT_RAW"},
 841     {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
 842 };
 843
 844 const struct flag_to_name op_exit_names[] = {
 845     {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
 846     {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
 847 };
 848
 849 #define OP_PRIVATE_ONCE(op, flag, name) \
 850     const struct flag_to_name CAT2(op, _names)[] = {    \
 851         {(flag), (name)} \
 852     }
 853
 854 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
 855 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
 856 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
 857 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
 858 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
 859 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
 860 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
 861 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
 862 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
 863 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
 864 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
 865 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
 866
 867 struct op_private_by_op {
 868     U16 op_type;
 869     U16 len;
 870     const struct flag_to_name *start;
 871 };
 872
 873 const struct op_private_by_op op_private_names[] = {
 874     {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 875     {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 876     {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 877     {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 878     {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
 879     {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
 880     {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
 881     {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
 882     {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
 883     {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
 884     {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
 885     {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
 886     {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
 887     {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
 888     {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
 889     {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
 890     {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
 891     {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
 892     {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
 893     {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
 894     {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
 895 };
 896
 897 static bool
 898 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
 899     const struct op_private_by_op *start = op_private_names;
 900     const struct op_private_by_op *const end
 901         = op_private_names + C_ARRAY_LENGTH(op_private_names);
 902
 903     /* This is a linear search, but no worse than the code that it replaced.
 904        It's debugging code - size is more important than speed.  */
 905     do {
 906         if (optype == start->op_type) {
 907             S_append_flags(aTHX_ tmpsv, op_private, start->start,
 908                            start->start + start->len);
 909             return TRUE;
 910         }
 911     } while (++start < end);
 912     return FALSE;
 913 }
 914
 915 void
 916 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 917 {
 918     dVAR;
 919     UV      seq;
 920     const OPCODE optype = o->op_type;
 921
 922     PERL_ARGS_ASSERT_DO_OP_DUMP;
 923
 924     sequence(o);
 925     Perl_dump_indent(aTHX_ level, file, "{\n");
 926     level++;
 927     seq = sequence_num(o);
 928     if (seq)
 929         PerlIO_printf(file, "%-4"UVuf, seq);
 930     else
 931         PerlIO_printf(file, "    ");
 932     PerlIO_printf(file,
 933                   "%*sTYPE = %s  ===> ",
 934                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
 935     if (o->op_next)
 936         PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
 937                                 sequence_num(o->op_next));
 938     else
 939         PerlIO_printf(file, "DONE\n");
 940     if (o->op_targ) {
 941         if (optype == OP_NULL) {
 942             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
 943             if (o->op_targ == OP_NEXTSTATE) {
 944                 if (CopLINE(cCOPo))
 945                     Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
 946                                      (UV)CopLINE(cCOPo));
 947                 if (CopSTASHPV(cCOPo))
 948                     Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
 949                                      CopSTASHPV(cCOPo));
 950                 if (CopLABEL(cCOPo))
 951                     Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
 952                                      CopLABEL(cCOPo));
 953             }
 954         }
 955         else
 956             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
 957     }
 958 #ifdef DUMPADDR
 959     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
 960 #endif
 961     if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
 962         SV * const tmpsv = newSVpvs("");
 963         switch (o->op_flags & OPf_WANT) {
 964         case OPf_WANT_VOID:
 965             sv_catpv(tmpsv, ",VOID");
 966             break;
 967         case OPf_WANT_SCALAR:
 968             sv_catpv(tmpsv, ",SCALAR");
 969             break;
 970         case OPf_WANT_LIST:
 971             sv_catpv(tmpsv, ",LIST");
 972             break;
 973         default:
 974             sv_catpv(tmpsv, ",UNKNOWN");
 975             break;
 976         }
 977         append_flags(tmpsv, o->op_flags, op_flags_names);
 978         if (o->op_latefree)
 979             sv_catpv(tmpsv, ",LATEFREE");
 980         if (o->op_latefreed)
 981             sv_catpv(tmpsv, ",LATEFREED");
 982         if (o->op_attached)
 983             sv_catpv(tmpsv, ",ATTACHED");
 984         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 985         SvREFCNT_dec(tmpsv);
 986     }
 987     if (o->op_private) {
 988         SV * const tmpsv = newSVpvs("");
 989         if (PL_opargs[optype] & OA_TARGLEX) {
 990             if (o->op_private & OPpTARGET_MY)
 991                 sv_catpv(tmpsv, ",TARGET_MY");
 992         }
 993         else if (optype == OP_ENTERSUB ||
 994             optype == OP_RV2SV ||
 995             optype == OP_GVSV ||
 996             optype == OP_RV2AV ||
 997             optype == OP_RV2HV ||
 998             optype == OP_RV2GV ||
 999             optype == OP_AELEM ||
1000             optype == OP_HELEM )
1001         {
1002             if (optype == OP_ENTERSUB) {
1003                 append_flags(tmpsv, o->op_private, op_entersub_names);
1004             }
1005             else {
1006                 switch (o->op_private & OPpDEREF) {
1007                 case OPpDEREF_SV:
1008                     sv_catpv(tmpsv, ",SV");
1009                     break;
1010                 case OPpDEREF_AV:
1011                     sv_catpv(tmpsv, ",AV");
1012                     break;
1013                 case OPpDEREF_HV:
1014                     sv_catpv(tmpsv, ",HV");
1015                     break;
1016                 }
1017                 if (o->op_private & OPpMAYBE_LVSUB)
1018                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
1019             }
1020
1021             if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
1022                     && (o->op_private & OPpDEREFed))
1023                 sv_catpv(tmpsv, ",DEREFed");
1024
1025             if (optype == OP_AELEM || optype == OP_HELEM) {
1026                 if (o->op_private & OPpLVAL_DEFER)
1027                     sv_catpv(tmpsv, ",LVAL_DEFER");
1028             }
1029             else {
1030                 if (o->op_private & HINT_STRICT_REFS)
1031                     sv_catpv(tmpsv, ",STRICT_REFS");
1032                 if (o->op_private & OPpOUR_INTRO)
1033                     sv_catpv(tmpsv, ",OUR_INTRO");
1034             }
1035         }
1036         else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
1037         }
1038         else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
1039             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1040                 sv_catpv(tmpsv, ",FT_ACCESS");
1041             if (o->op_private & OPpFT_STACKED)
1042                 sv_catpv(tmpsv, ",FT_STACKED");
1043         }
1044         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1045             sv_catpv(tmpsv, ",INTRO");
1046         if (SvCUR(tmpsv))
1047             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1048         SvREFCNT_dec(tmpsv);
1049     }
1050
1051 #ifdef PERL_MAD
1052     if (PL_madskills && o->op_madprop) {
1053         SV * const tmpsv = newSVpvs("");
1054         MADPROP* mp = o->op_madprop;
1055         Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1056         level++;
1057         while (mp) {
1058             const char tmp = mp->mad_key;
1059             sv_setpvs(tmpsv,"'");
1060             if (tmp)
1061                 sv_catpvn(tmpsv, &tmp, 1);
1062             sv_catpv(tmpsv, "'=");
1063             switch (mp->mad_type) {
1064             case MAD_NULL:
1065                 sv_catpv(tmpsv, "NULL");
1066                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1067                 break;
1068             case MAD_PV:
1069                 sv_catpv(tmpsv, "<");
1070                 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1071                 sv_catpv(tmpsv, ">");
1072                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1073                 break;
1074             case MAD_OP:
1075                 if ((OP*)mp->mad_val) {
1076                     Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1077                     do_op_dump(level, file, (OP*)mp->mad_val);
1078                 }
1079                 break;
1080             default:
1081                 sv_catpv(tmpsv, "(UNK)");
1082                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1083                 break;
1084             }
1085             mp = mp->mad_next;
1086         }
1087         level--;
1088         Perl_dump_indent(aTHX_ level, file, "}\n");
1089
1090         SvREFCNT_dec(tmpsv);
1091     }
1092 #endif
1093
1094     switch (optype) {
1095     case OP_AELEMFAST:
1096     case OP_GVSV:
1097     case OP_GV:
1098 #ifdef USE_ITHREADS
1099         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1100 #else
1101         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1102             if (cSVOPo->op_sv) {
1103                 SV * const tmpsv = newSV(0);
1104                 ENTER;
1105                 SAVEFREESV(tmpsv);
1106 #ifdef PERL_MAD
1107                 /* FIXME - is this making unwarranted assumptions about the
1108                    UTF-8 cleanliness of the dump file handle?  */
1109                 SvUTF8_on(tmpsv);
1110 #endif
1111                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1112                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1113                                  SvPV_nolen_const(tmpsv));
1114                 LEAVE;
1115             }
1116             else
1117                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1118         }
1119 #endif
1120         break;
1121     case OP_CONST:
1122     case OP_HINTSEVAL:
1123     case OP_METHOD_NAMED:
1124 #ifndef USE_ITHREADS
1125         /* with ITHREADS, consts are stored in the pad, and the right pad
1126          * may not be active here, so skip */
1127         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1128 #endif
1129         break;
1130     case OP_NEXTSTATE:
1131     case OP_DBSTATE:
1132         if (CopLINE(cCOPo))
1133             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1134                              (UV)CopLINE(cCOPo));
1135         if (CopSTASHPV(cCOPo))
1136             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1137                              CopSTASHPV(cCOPo));
1138         if (CopLABEL(cCOPo))
1139             Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1140                              CopLABEL(cCOPo));
1141         break;
1142     case OP_ENTERLOOP:
1143         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1144         if (cLOOPo->op_redoop)
1145             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1146         else
1147             PerlIO_printf(file, "DONE\n");
1148         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1149         if (cLOOPo->op_nextop)
1150             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1151         else
1152             PerlIO_printf(file, "DONE\n");
1153         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1154         if (cLOOPo->op_lastop)
1155             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1156         else
1157             PerlIO_printf(file, "DONE\n");
1158         break;
1159     case OP_COND_EXPR:
1160     case OP_RANGE:
1161     case OP_MAPWHILE:
1162     case OP_GREPWHILE:
1163     case OP_OR:
1164     case OP_AND:
1165         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1166         if (cLOGOPo->op_other)
1167             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1168         else
1169             PerlIO_printf(file, "DONE\n");
1170         break;
1171     case OP_PUSHRE:
1172     case OP_MATCH:
1173     case OP_QR:
1174     case OP_SUBST:
1175         do_pmop_dump(level, file, cPMOPo);
1176         break;
1177     case OP_LEAVE:
1178     case OP_LEAVEEVAL:
1179     case OP_LEAVESUB:
1180     case OP_LEAVESUBLV:
1181     case OP_LEAVEWRITE:
1182     case OP_SCOPE:
1183         if (o->op_private & OPpREFCOUNTED)
1184             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1185         break;
1186     default:
1187         break;
1188     }
1189     if (o->op_flags & OPf_KIDS) {
1190         OP *kid;
1191         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1192             do_op_dump(level, file, kid);
1193     }
1194     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1195 }
1196
1197 void
1198 Perl_op_dump(pTHX_ const OP *o)
1199 {
1200     PERL_ARGS_ASSERT_OP_DUMP;
1201     do_op_dump(0, Perl_debug_log, o);
1202 }
1203
1204 void
1205 Perl_gv_dump(pTHX_ GV *gv)
1206 {
1207     SV *sv;
1208
1209     PERL_ARGS_ASSERT_GV_DUMP;
1210
1211     if (!gv) {
1212         PerlIO_printf(Perl_debug_log, "{}\n");
1213         return;
1214     }
1215     sv = sv_newmortal();
1216     PerlIO_printf(Perl_debug_log, "{\n");
1217     gv_fullname3(sv, gv, NULL);
1218     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1219     if (gv != GvEGV(gv)) {
1220         gv_efullname3(sv, GvEGV(gv), NULL);
1221         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1222     }
1223     PerlIO_putc(Perl_debug_log, '\n');
1224     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1225 }
1226
1227
1228 /* map magic types to the symbolic names
1229  * (with the PERL_MAGIC_ prefixed stripped)
1230  */
1231
1232 static const struct { const char type; const char *name; } magic_names[] = {
1233         { PERL_MAGIC_sv,             "sv(\\0)" },
1234         { PERL_MAGIC_arylen,         "arylen(#)" },
1235         { PERL_MAGIC_rhash,          "rhash(%)" },
1236         { PERL_MAGIC_pos,            "pos(.)" },
1237         { PERL_MAGIC_symtab,         "symtab(:)" },
1238         { PERL_MAGIC_backref,        "backref(<)" },
1239         { PERL_MAGIC_arylen_p,       "arylen_p(@)" },
1240         { PERL_MAGIC_overload,       "overload(A)" },
1241         { PERL_MAGIC_bm,             "bm(B)" },
1242         { PERL_MAGIC_regdata,        "regdata(D)" },
1243         { PERL_MAGIC_env,            "env(E)" },
1244         { PERL_MAGIC_hints,          "hints(H)" },
1245         { PERL_MAGIC_isa,            "isa(I)" },
1246         { PERL_MAGIC_dbfile,         "dbfile(L)" },
1247         { PERL_MAGIC_shared,         "shared(N)" },
1248         { PERL_MAGIC_tied,           "tied(P)" },
1249         { PERL_MAGIC_sig,            "sig(S)" },
1250         { PERL_MAGIC_uvar,           "uvar(U)" },
1251         { PERL_MAGIC_overload_elem,  "overload_elem(a)" },
1252         { PERL_MAGIC_overload_table, "overload_table(c)" },
1253         { PERL_MAGIC_regdatum,       "regdatum(d)" },
1254         { PERL_MAGIC_envelem,        "envelem(e)" },
1255         { PERL_MAGIC_fm,             "fm(f)" },
1256         { PERL_MAGIC_regex_global,   "regex_global(g)" },
1257         { PERL_MAGIC_hintselem,      "hintselem(h)" },
1258         { PERL_MAGIC_isaelem,        "isaelem(i)" },
1259         { PERL_MAGIC_nkeys,          "nkeys(k)" },
1260         { PERL_MAGIC_dbline,         "dbline(l)" },
1261         { PERL_MAGIC_shared_scalar,  "shared_scalar(n)" },
1262         { PERL_MAGIC_collxfrm,       "collxfrm(o)" },
1263         { PERL_MAGIC_tiedelem,       "tiedelem(p)" },
1264         { PERL_MAGIC_tiedscalar,     "tiedscalar(q)" },
1265         { PERL_MAGIC_qr,             "qr(r)" },
1266         { PERL_MAGIC_sigelem,        "sigelem(s)" },
1267         { PERL_MAGIC_taint,          "taint(t)" },
1268         { PERL_MAGIC_uvar_elem,      "uvar_elem(u)" },
1269         { PERL_MAGIC_vec,            "vec(v)" },
1270         { PERL_MAGIC_vstring,        "vstring(V)" },
1271         { PERL_MAGIC_utf8,           "utf8(w)" },
1272         { PERL_MAGIC_substr,         "substr(x)" },
1273         { PERL_MAGIC_defelem,        "defelem(y)" },
1274         { PERL_MAGIC_ext,            "ext(~)" },
1275         /* this null string terminates the list */
1276         { 0,                         NULL },
1277 };
1278
1279 void
1280 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1281 {
1282     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1283
1284     for (; mg; mg = mg->mg_moremagic) {
1285         Perl_dump_indent(aTHX_ level, file,
1286                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1287         if (mg->mg_virtual) {
1288             const MGVTBL * const v = mg->mg_virtual;
1289             const char *s;
1290             if      (v == &PL_vtbl_sv)         s = "sv";
1291             else if (v == &PL_vtbl_env)        s = "env";
1292             else if (v == &PL_vtbl_envelem)    s = "envelem";
1293             else if (v == &PL_vtbl_sig)        s = "sig";
1294             else if (v == &PL_vtbl_sigelem)    s = "sigelem";
1295             else if (v == &PL_vtbl_pack)       s = "pack";
1296             else if (v == &PL_vtbl_packelem)   s = "packelem";
1297             else if (v == &PL_vtbl_dbline)     s = "dbline";
1298             else if (v == &PL_vtbl_isa)        s = "isa";
1299             else if (v == &PL_vtbl_arylen)     s = "arylen";
1300             else if (v == &PL_vtbl_mglob)      s = "mglob";
1301             else if (v == &PL_vtbl_nkeys)      s = "nkeys";
1302             else if (v == &PL_vtbl_taint)      s = "taint";
1303             else if (v == &PL_vtbl_substr)     s = "substr";
1304             else if (v == &PL_vtbl_vec)        s = "vec";
1305             else if (v == &PL_vtbl_pos)        s = "pos";
1306             else if (v == &PL_vtbl_bm)         s = "bm";
1307             else if (v == &PL_vtbl_fm)         s = "fm";
1308             else if (v == &PL_vtbl_uvar)       s = "uvar";
1309             else if (v == &PL_vtbl_defelem)    s = "defelem";
1310 #ifdef USE_LOCALE_COLLATE
1311             else if (v == &PL_vtbl_collxfrm)   s = "collxfrm";
1312 #endif
1313             else if (v == &PL_vtbl_amagic)     s = "amagic";
1314             else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1315             else if (v == &PL_vtbl_backref)    s = "backref";
1316             else if (v == &PL_vtbl_utf8)       s = "utf8";
1317             else if (v == &PL_vtbl_arylen_p)   s = "arylen_p";
1318             else if (v == &PL_vtbl_hintselem)  s = "hintselem";
1319             else if (v == &PL_vtbl_hints)      s = "hints";
1320             else                               s = NULL;
1321             if (s)
1322                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
1323             else
1324                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1325         }
1326         else
1327             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1328
1329         if (mg->mg_private)
1330             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1331
1332         {
1333             int n;
1334             const char *name = NULL;
1335             for (n = 0; magic_names[n].name; n++) {
1336                 if (mg->mg_type == magic_names[n].type) {
1337                     name = magic_names[n].name;
1338                     break;
1339                 }
1340             }
1341             if (name)
1342                 Perl_dump_indent(aTHX_ level, file,
1343                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1344             else
1345                 Perl_dump_indent(aTHX_ level, file,
1346                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1347         }
1348
1349         if (mg->mg_flags) {
1350             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1351             if (mg->mg_type == PERL_MAGIC_envelem &&
1352                 mg->mg_flags & MGf_TAINTEDDIR)
1353                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1354             if (mg->mg_flags & MGf_REFCOUNTED)
1355                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1356             if (mg->mg_flags & MGf_GSKIP)
1357                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1358             if (mg->mg_type == PERL_MAGIC_regex_global &&
1359                 mg->mg_flags & MGf_MINMATCH)
1360                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1361         }
1362         if (mg->mg_obj) {
1363             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1364                 PTR2UV(mg->mg_obj));
1365             if (mg->mg_type == PERL_MAGIC_qr) {
1366                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1367                 SV * const dsv = sv_newmortal();
1368                 const char * const s
1369                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1370                     60, NULL, NULL,
1371                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1372                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1373                 );
1374                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1375                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1376                         (IV)RX_REFCNT(re));
1377             }
1378             if (mg->mg_flags & MGf_REFCOUNTED)
1379                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1380         }
1381         if (mg->mg_len)
1382             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1383         if (mg->mg_ptr) {
1384             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1385             if (mg->mg_len >= 0) {
1386                 if (mg->mg_type != PERL_MAGIC_utf8) {
1387                     SV * const sv = newSVpvs("");
1388                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1389                     SvREFCNT_dec(sv);
1390                 }
1391             }
1392             else if (mg->mg_len == HEf_SVKEY) {
1393                 PerlIO_puts(file, " => HEf_SVKEY\n");
1394                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1395                            maxnest, dumpops, pvlim); /* MG is already +1 */
1396                 continue;
1397             }
1398             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1399             else
1400                 PerlIO_puts(
1401                   file,
1402                  " ???? - " __FILE__
1403                  " does not know how to handle this MG_LEN"
1404                 );
1405             PerlIO_putc(file, '\n');
1406         }
1407         if (mg->mg_type == PERL_MAGIC_utf8) {
1408             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1409             if (cache) {
1410                 IV i;
1411                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1412                     Perl_dump_indent(aTHX_ level, file,
1413                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1414                                      i,
1415                                      (UV)cache[i * 2],
1416                                      (UV)cache[i * 2 + 1]);
1417             }
1418         }
1419     }
1420 }
1421
1422 void
1423 Perl_magic_dump(pTHX_ const MAGIC *mg)
1424 {
1425     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1426 }
1427
1428 void
1429 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1430 {
1431     const char *hvname;
1432
1433     PERL_ARGS_ASSERT_DO_HV_DUMP;
1434
1435     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1436     if (sv && (hvname = HvNAME_get(sv)))
1437         PerlIO_printf(file, "\t\"%s\"\n", hvname);
1438     else
1439         PerlIO_putc(file, '\n');
1440 }
1441
1442 void
1443 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1444 {
1445     PERL_ARGS_ASSERT_DO_GV_DUMP;
1446
1447     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1448     if (sv && GvNAME(sv))
1449         PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1450     else
1451         PerlIO_putc(file, '\n');
1452 }
1453
1454 void
1455 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1456 {
1457     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1458
1459     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1460     if (sv && GvNAME(sv)) {
1461         const char *hvname;
1462         PerlIO_printf(file, "\t\"");
1463         if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1464             PerlIO_printf(file, "%s\" :: \"", hvname);
1465         PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1466     }
1467     else
1468         PerlIO_putc(file, '\n');
1469 }
1470
1471 const struct flag_to_name first_sv_flags_names[] = {
1472     {SVs_TEMP, "TEMP,"},
1473     {SVs_OBJECT, "OBJECT,"},
1474     {SVs_GMG, "GMG,"},
1475     {SVs_SMG, "SMG,"},
1476     {SVs_RMG, "RMG,"},
1477     {SVf_IOK, "IOK,"},
1478     {SVf_NOK, "NOK,"},
1479     {SVf_POK, "POK,"}
1480 };
1481
1482 const struct flag_to_name second_sv_flags_names[] = {
1483     {SVf_OOK, "OOK,"},
1484     {SVf_FAKE, "FAKE,"},
1485     {SVf_READONLY, "READONLY,"},
1486     {SVf_BREAK, "BREAK,"},
1487     {SVf_AMAGIC, "OVERLOAD,"},
1488     {SVp_IOK, "pIOK,"},
1489     {SVp_NOK, "pNOK,"},
1490     {SVp_POK, "pPOK,"}
1491 };
1492
1493 const struct flag_to_name cv_flags_names[] = {
1494     {CVf_ANON, "ANON,"},
1495     {CVf_UNIQUE, "UNIQUE,"},
1496     {CVf_CLONE, "CLONE,"},
1497     {CVf_CLONED, "CLONED,"},
1498     {CVf_CONST, "CONST,"},
1499     {CVf_NODEBUG, "NODEBUG,"},
1500     {CVf_LVALUE, "LVALUE,"},
1501     {CVf_METHOD, "METHOD,"},
1502     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1503     {CVf_CVGV_RC, "CVGV_RC,"},
1504     {CVf_ISXSUB, "ISXSUB,"}
1505 };
1506
1507 const struct flag_to_name hv_flags_names[] = {
1508     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1509     {SVphv_LAZYDEL, "LAZYDEL,"},
1510     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1511     {SVphv_REHASH, "REHASH,"},
1512     {SVphv_CLONEABLE, "CLONEABLE,"}
1513 };
1514
1515 const struct flag_to_name gp_flags_names[] = {
1516     {GVf_INTRO, "INTRO,"},
1517     {GVf_MULTI, "MULTI,"},
1518     {GVf_ASSUMECV, "ASSUMECV,"},
1519     {GVf_IN_PAD, "IN_PAD,"}
1520 };
1521
1522 const struct flag_to_name gp_flags_imported_names[] = {
1523     {GVf_IMPORTED_SV, " SV"},
1524     {GVf_IMPORTED_AV, " AV"},
1525     {GVf_IMPORTED_HV, " HV"},
1526     {GVf_IMPORTED_CV, " CV"},
1527 };
1528
1529 void
1530 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1531 {
1532     dVAR;
1533     SV *d;
1534     const char *s;
1535     U32 flags;
1536     U32 type;
1537
1538     PERL_ARGS_ASSERT_DO_SV_DUMP;
1539
1540     if (!sv) {
1541         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1542         return;
1543     }
1544
1545     flags = SvFLAGS(sv);
1546     type = SvTYPE(sv);
1547
1548     d = Perl_newSVpvf(aTHX_
1549                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1550                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1551                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1552                    (int)(PL_dumpindent*level), "");
1553
1554     if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) {
1555         if (flags & SVs_PADSTALE)       sv_catpv(d, "PADSTALE,");
1556     }
1557     if (!(flags & SVpad_NAME && type == SVt_PVMG)) {
1558         if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1559         if (flags & SVs_PADMY)  sv_catpv(d, "PADMY,");
1560     }
1561     append_flags(d, flags, first_sv_flags_names);
1562     if (flags & SVf_ROK)  {
1563                                 sv_catpv(d, "ROK,");
1564         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1565     }
1566     append_flags(d, flags, second_sv_flags_names);
1567     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1568         if (SvPCS_IMPORTED(sv))
1569                                 sv_catpv(d, "PCS_IMPORTED,");
1570         else
1571                                 sv_catpv(d, "SCREAM,");
1572     }
1573
1574     switch (type) {
1575     case SVt_PVCV:
1576     case SVt_PVFM:
1577         append_flags(d, CvFLAGS(sv), cv_flags_names);
1578         if (SvCOMPILED(sv))     sv_catpv(d, "COMPILED,");
1579         break;
1580     case SVt_PVHV:
1581         append_flags(d, flags, hv_flags_names);
1582         break;
1583     case SVt_PVGV:
1584     case SVt_PVLV:
1585         if (isGV_with_GP(sv)) {
1586             append_flags(d, GvFLAGS(sv), gp_flags_names);
1587         }
1588         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1589             sv_catpv(d, "IMPORT");
1590             if (GvIMPORTED(sv) == GVf_IMPORTED)
1591                 sv_catpv(d, "ALL,");
1592             else {
1593                 sv_catpv(d, "(");
1594                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1595                 sv_catpv(d, " ),");
1596             }
1597         }
1598         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1599         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1600         /* FALL THROUGH */
1601     default:
1602     evaled_or_uv:
1603         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1604         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1605         break;
1606     case SVt_PVMG:
1607         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1608         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1609         /* FALL THROUGH */
1610     case SVt_PVNV:
1611         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1612         goto evaled_or_uv;
1613     case SVt_PVAV:
1614         break;
1615     }
1616     /* SVphv_SHAREKEYS is also 0x20000000 */
1617     if ((type != SVt_PVHV) && SvUTF8(sv))
1618         sv_catpv(d, "UTF8");
1619
1620     if (*(SvEND(d) - 1) == ',') {
1621         SvCUR_set(d, SvCUR(d) - 1);
1622         SvPVX(d)[SvCUR(d)] = '\0';
1623     }
1624     sv_catpv(d, ")");
1625     s = SvPVX_const(d);
1626
1627 #ifdef DEBUG_LEAKING_SCALARS
1628     Perl_dump_indent(aTHX_ level, file,
1629         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1630         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1631         sv->sv_debug_line,
1632         sv->sv_debug_inpad ? "for" : "by",
1633         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1634         PTR2UV(sv->sv_debug_parent),
1635         sv->sv_debug_serial
1636     );
1637 #endif
1638     Perl_dump_indent(aTHX_ level, file, "SV = ");
1639     if (type < SVt_LAST) {
1640         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1641
1642         if (type ==  SVt_NULL) {
1643             SvREFCNT_dec(d);
1644             return;
1645         }
1646     } else {
1647         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1648         SvREFCNT_dec(d);
1649         return;
1650     }
1651     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1652          && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM
1653          && type != SVt_PVIO && type != SVt_REGEXP)
1654         || (type == SVt_IV && !SvROK(sv))) {
1655         if (SvIsUV(sv)
1656 #ifdef PERL_OLD_COPY_ON_WRITE
1657                        || SvIsCOW(sv)
1658 #endif
1659                                      )
1660             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1661         else
1662             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1663 #ifdef PERL_OLD_COPY_ON_WRITE
1664         if (SvIsCOW_shared_hash(sv))
1665             PerlIO_printf(file, "  (HASH)");
1666         else if (SvIsCOW_normal(sv))
1667             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1668 #endif
1669         PerlIO_putc(file, '\n');
1670     }
1671     if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1672         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1673                          (UV) COP_SEQ_RANGE_LOW(sv));
1674         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1675                          (UV) COP_SEQ_RANGE_HIGH(sv));
1676     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1677                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1678                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1679                || type == SVt_NV) {
1680         STORE_NUMERIC_LOCAL_SET_STANDARD();
1681         /* %Vg doesn't work? --jhi */
1682 #ifdef USE_LONG_DOUBLE
1683         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1684 #else
1685         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1686 #endif
1687         RESTORE_NUMERIC_LOCAL();
1688     }
1689     if (SvROK(sv)) {
1690         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1691         if (nest < maxnest)
1692             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1693     }
1694     if (type < SVt_PV) {
1695         SvREFCNT_dec(d);
1696         return;
1697     }
1698     if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1699         if (SvPVX_const(sv)) {
1700             STRLEN delta;
1701             if (SvOOK(sv)) {
1702                 SvOOK_offset(sv, delta);
1703                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1704                                  (UV) delta);
1705             } else {
1706                 delta = 0;
1707             }
1708             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1709             if (SvOOK(sv)) {
1710                 PerlIO_printf(file, "( %s . ) ",
1711                               pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1712                                          pvlim));
1713             }
1714             PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1715             if (SvUTF8(sv)) /* the 6?  \x{....} */
1716                 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1717             PerlIO_printf(file, "\n");
1718             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1719             Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
1720         }
1721         else
1722             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1723     }
1724     if (type == SVt_REGEXP) {
1725         /* FIXME dumping
1726             Perl_dump_indent(aTHX_ level, file, "  REGEXP = 0x%"UVxf"\n",
1727                              PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1728         */
1729     }
1730     if (type >= SVt_PVMG) {
1731         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1732             HV * const ost = SvOURSTASH(sv);
1733             if (ost)
1734                 do_hv_dump(level, file, "  OURSTASH", ost);
1735         } else {
1736             if (SvMAGIC(sv))
1737                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1738         }
1739         if (SvSTASH(sv))
1740             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1741     }
1742     switch (type) {
1743     case SVt_PVAV:
1744         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1745         if (AvARRAY(sv) != AvALLOC(sv)) {
1746             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1747             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1748         }
1749         else
1750             PerlIO_putc(file, '\n');
1751         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1752         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1753         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1754         sv_setpvs(d, "");
1755         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1756         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1757         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1758                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1759         if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1760             int count;
1761             for (count = 0; count <=  av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1762                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1763
1764                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1765                 if (elt)
1766                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1767             }
1768         }
1769         break;
1770     case SVt_PVHV:
1771         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1772         if (HvARRAY(sv) && HvKEYS(sv)) {
1773             /* Show distribution of HEs in the ARRAY */
1774             int freq[200];
1775 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1776             int i;
1777             int max = 0;
1778             U32 pow2 = 2, keys = HvKEYS(sv);
1779             NV theoret, sum = 0;
1780
1781             PerlIO_printf(file, "  (");
1782             Zero(freq, FREQ_MAX + 1, int);
1783             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1784                 HE* h;
1785                 int count = 0;
1786                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1787                     count++;
1788                 if (count > FREQ_MAX)
1789                     count = FREQ_MAX;
1790                 freq[count]++;
1791                 if (max < count)
1792                     max = count;
1793             }
1794             for (i = 0; i <= max; i++) {
1795                 if (freq[i]) {
1796                     PerlIO_printf(file, "%d%s:%d", i,
1797                                   (i == FREQ_MAX) ? "+" : "",
1798                                   freq[i]);
1799                     if (i != max)
1800                         PerlIO_printf(file, ", ");
1801                 }
1802             }
1803             PerlIO_putc(file, ')');
1804             /* The "quality" of a hash is defined as the total number of
1805                comparisons needed to access every element once, relative
1806                to the expected number needed for a random hash.
1807
1808                The total number of comparisons is equal to the sum of
1809                the squares of the number of entries in each bucket.
1810                For a random hash of n keys into k buckets, the expected
1811                value is
1812                                 n + n(n-1)/2k
1813             */
1814
1815             for (i = max; i > 0; i--) { /* Precision: count down. */
1816                 sum += freq[i] * i * i;
1817             }
1818             while ((keys = keys >> 1))
1819                 pow2 = pow2 << 1;
1820             theoret = HvKEYS(sv);
1821             theoret += theoret * (theoret-1)/pow2;
1822             PerlIO_putc(file, '\n');
1823             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1824         }
1825         PerlIO_putc(file, '\n');
1826         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1827         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1828         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1829         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1830         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1831         {
1832             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1833             if (mg && mg->mg_obj) {
1834                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1835             }
1836         }
1837         {
1838             const char * const hvname = HvNAME_get(sv);
1839             if (hvname)
1840                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1841         }
1842         if (SvOOK(sv)) {
1843             AV * const backrefs
1844                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1845             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1846             if (backrefs) {
1847                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1848                                  PTR2UV(backrefs));
1849                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1850                            dumpops, pvlim);
1851             }
1852             if (meta) {
1853                 /* FIXME - mro_algs kflags can signal a UTF-8 name.  */
1854                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1855                                  (int)meta->mro_which->length,
1856                                  meta->mro_which->name,
1857                                  PTR2UV(meta->mro_which));
1858                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1859                                  (UV)meta->cache_gen);
1860                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1861                                  (UV)meta->pkg_gen);
1862                 if (meta->mro_linear_all) {
1863                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1864                                  PTR2UV(meta->mro_linear_all));
1865                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1866                            dumpops, pvlim);
1867                 }
1868                 if (meta->mro_linear_current) {
1869                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1870                                  PTR2UV(meta->mro_linear_current));
1871                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1872                            dumpops, pvlim);
1873                 }
1874                 if (meta->mro_nextmethod) {
1875                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1876                                  PTR2UV(meta->mro_nextmethod));
1877                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1878                            dumpops, pvlim);
1879                 }
1880                 if (meta->isa) {
1881                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1882                                  PTR2UV(meta->isa));
1883                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1884                            dumpops, pvlim);
1885                 }
1886             }
1887         }
1888         if (nest < maxnest) {
1889             if (HvEITER_get(sv)) /* preserve iterator */
1890                 Perl_dump_indent(aTHX_ level, file,
1891                     "  (*** Active iterator; skipping element dump ***)\n");
1892             else {
1893                 HE *he;
1894                 HV * const hv = MUTABLE_HV(sv);
1895                 int count = maxnest - nest;
1896
1897                 hv_iterinit(hv);
1898                 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1899                        && count--) {
1900                     STRLEN len;
1901                     const U32 hash = HeHASH(he);
1902                     SV * const keysv = hv_iterkeysv(he);
1903                     const char * const keypv = SvPV_const(keysv, len);
1904                     SV * const elt = hv_iterval(hv, he);
1905
1906                     Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1907                     if (SvUTF8(keysv))
1908                         PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1909                     if (HeKREHASH(he))
1910                         PerlIO_printf(file, "[REHASH] ");
1911                     PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1912                     do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1913                 }
1914                 hv_iterinit(hv);                /* Return to status quo */
1915             }
1916         }
1917         break;
1918     case SVt_PVCV:
1919         if (SvPOK(sv)) {
1920             STRLEN len;
1921             const char *const proto =  SvPV_const(sv, len);
1922             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1923                              (int) len, proto);
1924         }
1925         /* FALL THROUGH */
1926     case SVt_PVFM:
1927         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1928         if (!CvISXSUB(sv)) {
1929             if (CvSTART(sv)) {
1930                 Perl_dump_indent(aTHX_ level, file,
1931                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1932                                  PTR2UV(CvSTART(sv)),
1933                                  (IV)sequence_num(CvSTART(sv)));
1934             }
1935             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1936                              PTR2UV(CvROOT(sv)));
1937             if (CvROOT(sv) && dumpops) {
1938                 do_op_dump(level+1, file, CvROOT(sv));
1939             }
1940         } else {
1941             SV * const constant = cv_const_sv((const CV *)sv);
1942
1943             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1944
1945             if (constant) {
1946                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1947                                  " (CONST SV)\n",
1948                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1949                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1950                            pvlim);
1951             } else {
1952                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1953                                  (IV)CvXSUBANY(sv).any_i32);
1954             }
1955         }
1956         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1957         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1958         if (type == SVt_PVCV)
1959             Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1960         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1961         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1962         if (type == SVt_PVFM)
1963             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
1964         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1965         if (nest < maxnest) {
1966             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1967         }
1968         {
1969             const CV * const outside = CvOUTSIDE(sv);
1970             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1971                         PTR2UV(outside),
1972                         (!outside ? "null"
1973                          : CvANON(outside) ? "ANON"
1974                          : (outside == PL_main_cv) ? "MAIN"
1975                          : CvUNIQUE(outside) ? "UNIQUE"
1976                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1977         }
1978         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1979             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1980         break;
1981     case SVt_PVGV:
1982     case SVt_PVLV:
1983         if (type == SVt_PVLV) {
1984             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
1985             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1986             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1987             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1988             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1989                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1990                     dumpops, pvlim);
1991         }
1992         if (SvVALID(sv)) {
1993             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %u\n", (U8)BmFLAGS(sv));
1994             Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
1995             Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1996             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1997         }
1998         if (!isGV_with_GP(sv))
1999             break;
2000         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
2001         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2002         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2003         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2004         if (!GvGP(sv))
2005             break;
2006         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2007         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2008         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2009         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2010         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2011         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2012         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2013         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2014         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2015         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2016         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2017         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2018         break;
2019     case SVt_PVIO:
2020         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2021         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2022         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2023         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2024         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2025         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2026         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2027         if (IoTOP_NAME(sv))
2028             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2029         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2030             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2031         else {
2032             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2033                              PTR2UV(IoTOP_GV(sv)));
2034             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2035                         maxnest, dumpops, pvlim);
2036         }
2037         /* Source filters hide things that are not GVs in these three, so let's
2038            be careful out there.  */
2039         if (IoFMT_NAME(sv))
2040             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2041         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2042             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2043         else {
2044             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2045                              PTR2UV(IoFMT_GV(sv)));
2046             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2047                         maxnest, dumpops, pvlim);
2048         }
2049         if (IoBOTTOM_NAME(sv))
2050             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2051         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2052             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2053         else {
2054             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2055                              PTR2UV(IoBOTTOM_GV(sv)));
2056             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2057                         maxnest, dumpops, pvlim);
2058         }
2059         if (isPRINT(IoTYPE(sv)))
2060             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2061         else
2062             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2063         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2064         break;
2065     }
2066     SvREFCNT_dec(d);
2067 }
2068
2069 void
2070 Perl_sv_dump(pTHX_ SV *sv)
2071 {
2072     dVAR;
2073
2074     PERL_ARGS_ASSERT_SV_DUMP;
2075
2076     if (SvROK(sv))
2077         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2078     else
2079         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2080 }
2081
2082 int
2083 Perl_runops_debug(pTHX)
2084 {
2085     dVAR;
2086     if (!PL_op) {
2087         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2088         return 0;
2089     }
2090
2091     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2092     do {
2093         if (PL_debug) {
2094             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2095                 PerlIO_printf(Perl_debug_log,
2096                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2097                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2098                               PTR2UV(*PL_watchaddr));
2099             if (DEBUG_s_TEST_) {
2100                 if (DEBUG_v_TEST_) {
2101                     PerlIO_printf(Perl_debug_log, "\n");
2102                     deb_stack_all();
2103                 }
2104                 else
2105                     debstack();
2106             }
2107
2108
2109             if (DEBUG_t_TEST_) debop(PL_op);
2110             if (DEBUG_P_TEST_) debprof(PL_op);
2111         }
2112     } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
2113     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2114
2115     TAINT_NOT;
2116     return 0;
2117 }
2118
2119 I32
2120 Perl_debop(pTHX_ const OP *o)
2121 {
2122     dVAR;
2123
2124     PERL_ARGS_ASSERT_DEBOP;
2125
2126     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2127         return 0;
2128
2129     Perl_deb(aTHX_ "%s", OP_NAME(o));
2130     switch (o->op_type) {
2131     case OP_CONST:
2132     case OP_HINTSEVAL:
2133         /* With ITHREADS, consts are stored in the pad, and the right pad
2134          * may not be active here, so check.
2135          * Looks like only during compiling the pads are illegal.
2136          */
2137 #ifdef USE_ITHREADS
2138         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2139 #endif
2140             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2141         break;
2142     case OP_GVSV:
2143     case OP_GV:
2144         if (cGVOPo_gv) {
2145             SV * const sv = newSV(0);
2146 #ifdef PERL_MAD
2147             /* FIXME - is this making unwarranted assumptions about the
2148                UTF-8 cleanliness of the dump file handle?  */
2149             SvUTF8_on(sv);
2150 #endif
2151             gv_fullname3(sv, cGVOPo_gv, NULL);
2152             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2153             SvREFCNT_dec(sv);
2154         }
2155         else
2156             PerlIO_printf(Perl_debug_log, "(NULL)");
2157         break;
2158     case OP_PADSV:
2159     case OP_PADAV:
2160     case OP_PADHV:
2161         {
2162         /* print the lexical's name */
2163         CV * const cv = deb_curcv(cxstack_ix);
2164         SV *sv;
2165         if (cv) {
2166             AV * const padlist = CvPADLIST(cv);
2167             AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2168             sv = *av_fetch(comppad, o->op_targ, FALSE);
2169         } else
2170             sv = NULL;
2171         if (sv)
2172             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2173         else
2174             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2175         }
2176         break;
2177     default:
2178         break;
2179     }
2180     PerlIO_printf(Perl_debug_log, "\n");
2181     return 0;
2182 }
2183
2184 STATIC CV*
2185 S_deb_curcv(pTHX_ const I32 ix)
2186 {
2187     dVAR;
2188     const PERL_CONTEXT * const cx = &cxstack[ix];
2189     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2190         return cx->blk_sub.cv;
2191     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2192         return PL_compcv;
2193     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2194         return PL_main_cv;
2195     else if (ix <= 0)
2196         return NULL;
2197     else
2198         return deb_curcv(ix - 1);
2199 }
2200
2201 void
2202 Perl_watch(pTHX_ char **addr)
2203 {
2204     dVAR;
2205
2206     PERL_ARGS_ASSERT_WATCH;
2207
2208     PL_watchaddr = addr;
2209     PL_watchok = *addr;
2210     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2211         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2212 }
2213
2214 STATIC void
2215 S_debprof(pTHX_ const OP *o)
2216 {
2217     dVAR;
2218
2219     PERL_ARGS_ASSERT_DEBPROF;
2220
2221     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2222         return;
2223     if (!PL_profiledata)
2224         Newxz(PL_profiledata, MAXO, U32);
2225     ++PL_profiledata[o->op_type];
2226 }
2227
2228 void
2229 Perl_debprofdump(pTHX)
2230 {
2231     dVAR;
2232     unsigned i;
2233     if (!PL_profiledata)
2234         return;
2235     for (i = 0; i < MAXO; i++) {
2236         if (PL_profiledata[i])
2237             PerlIO_printf(Perl_debug_log,
2238                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2239                                        PL_op_name[i]);
2240     }
2241 }
2242
2243 #ifdef PERL_MAD
2244 /*
2245  *    XML variants of most of the above routines
2246  */
2247
2248 STATIC void
2249 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2250 {
2251     va_list args;
2252
2253     PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2254
2255     PerlIO_printf(file, "\n    ");
2256     va_start(args, pat);
2257     xmldump_vindent(level, file, pat, &args);
2258     va_end(args);
2259 }
2260
2261
2262 void
2263 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2264 {
2265     va_list args;
2266     PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2267     va_start(args, pat);
2268     xmldump_vindent(level, file, pat, &args);
2269     va_end(args);
2270 }
2271
2272 void
2273 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2274 {
2275     PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2276
2277     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2278     PerlIO_vprintf(file, pat, *args);
2279 }
2280
2281 void
2282 Perl_xmldump_all(pTHX)
2283 {
2284     xmldump_all_perl(FALSE);
2285 }
2286
2287 void
2288 Perl_xmldump_all_perl(pTHX_ bool justperl)
2289 {
2290     PerlIO_setlinebuf(PL_xmlfp);
2291     if (PL_main_root)
2292         op_xmldump(PL_main_root);
2293     xmldump_packsubs_perl(PL_defstash, justperl);
2294     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2295         PerlIO_close(PL_xmlfp);
2296     PL_xmlfp = 0;
2297 }
2298
2299 void
2300 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2301 {
2302     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2303     xmldump_packsubs_perl(stash, FALSE);
2304 }
2305
2306 void
2307 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2308 {
2309     I32 i;
2310     HE  *entry;
2311
2312     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2313
2314     if (!HvARRAY(stash))
2315         return;
2316     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2317         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2318             GV *gv = MUTABLE_GV(HeVAL(entry));
2319             HV *hv;
2320             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2321                 continue;
2322             if (GvCVu(gv))
2323                 xmldump_sub_perl(gv, justperl);
2324             if (GvFORM(gv))
2325                 xmldump_form(gv);
2326             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2327                 && (hv = GvHV(gv)) && hv != PL_defstash)
2328                 xmldump_packsubs_perl(hv, justperl);    /* nested package */
2329         }
2330     }
2331 }
2332
2333 void
2334 Perl_xmldump_sub(pTHX_ const GV *gv)
2335 {
2336     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2337     xmldump_sub_perl(gv, FALSE);
2338 }
2339
2340 void
2341 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2342 {
2343     SV * sv;
2344
2345     PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2346
2347     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2348         return;
2349
2350     sv = sv_newmortal();
2351     gv_fullname3(sv, gv, NULL);
2352     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2353     if (CvXSUB(GvCV(gv)))
2354         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2355             PTR2UV(CvXSUB(GvCV(gv))),
2356             (int)CvXSUBANY(GvCV(gv)).any_i32);
2357     else if (CvROOT(GvCV(gv)))
2358         op_xmldump(CvROOT(GvCV(gv)));
2359     else
2360         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2361 }
2362
2363 void
2364 Perl_xmldump_form(pTHX_ const GV *gv)
2365 {
2366     SV * const sv = sv_newmortal();
2367
2368     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2369
2370     gv_fullname3(sv, gv, NULL);
2371     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2372     if (CvROOT(GvFORM(gv)))
2373         op_xmldump(CvROOT(GvFORM(gv)));
2374     else
2375         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2376 }
2377
2378 void
2379 Perl_xmldump_eval(pTHX)
2380 {
2381     op_xmldump(PL_eval_root);
2382 }
2383
2384 char *
2385 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2386 {
2387     PERL_ARGS_ASSERT_SV_CATXMLSV;
2388     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2389 }
2390
2391 char *
2392 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2393 {
2394     unsigned int c;
2395     const char * const e = pv + len;
2396     const char * const start = pv;
2397     STRLEN dsvcur;
2398     STRLEN cl;
2399
2400     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2401
2402     sv_catpvs(dsv,"");
2403     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2404
2405   retry:
2406     while (pv < e) {
2407         if (utf8) {
2408             c = utf8_to_uvchr((U8*)pv, &cl);
2409             if (cl == 0) {
2410                 SvCUR(dsv) = dsvcur;
2411                 pv = start;
2412                 utf8 = 0;
2413                 goto retry;
2414             }
2415         }
2416         else
2417             c = (*pv & 255);
2418
2419         switch (c) {
2420         case 0x00:
2421         case 0x01:
2422         case 0x02:
2423         case 0x03:
2424         case 0x04:
2425         case 0x05:
2426         case 0x06:
2427         case 0x07:
2428         case 0x08:
2429         case 0x0b:
2430         case 0x0c:
2431         case 0x0e:
2432         case 0x0f:
2433         case 0x10:
2434         case 0x11:
2435         case 0x12:
2436         case 0x13:
2437         case 0x14:
2438         case 0x15:
2439         case 0x16:
2440         case 0x17:
2441         case 0x18:
2442         case 0x19:
2443         case 0x1a:
2444         case 0x1b:
2445         case 0x1c:
2446         case 0x1d:
2447         case 0x1e:
2448         case 0x1f:
2449         case 0x7f:
2450         case 0x80:
2451         case 0x81:
2452         case 0x82:
2453         case 0x83:
2454         case 0x84:
2455         case 0x86:
2456         case 0x87:
2457         case 0x88:
2458         case 0x89:
2459         case 0x90:
2460         case 0x91:
2461         case 0x92:
2462         case 0x93:
2463         case 0x94:
2464         case 0x95:
2465         case 0x96:
2466         case 0x97:
2467         case 0x98:
2468         case 0x99:
2469         case 0x9a:
2470         case 0x9b:
2471         case 0x9c:
2472         case 0x9d:
2473         case 0x9e:
2474         case 0x9f:
2475             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2476             break;
2477         case '<':
2478             sv_catpvs(dsv, "&lt;");
2479             break;
2480         case '>':
2481             sv_catpvs(dsv, "&gt;");
2482             break;
2483         case '&':
2484             sv_catpvs(dsv, "&amp;");
2485             break;
2486         case '"':
2487             sv_catpvs(dsv, "&#34;");
2488             break;
2489         default:
2490             if (c < 0xD800) {
2491                 if (c < 32 || c > 127) {
2492                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2493                 }
2494                 else {
2495                     const char string = (char) c;
2496                     sv_catpvn(dsv, &string, 1);
2497                 }
2498                 break;
2499             }
2500             if ((c >= 0xD800 && c <= 0xDB7F) ||
2501                 (c >= 0xDC00 && c <= 0xDFFF) ||
2502                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2503                  c > 0x10ffff)
2504                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2505             else
2506                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2507         }
2508
2509         if (utf8)
2510             pv += UTF8SKIP(pv);
2511         else
2512             pv++;
2513     }
2514
2515     return SvPVX(dsv);
2516 }
2517
2518 char *
2519 Perl_sv_xmlpeek(pTHX_ SV *sv)
2520 {
2521     SV * const t = sv_newmortal();
2522     STRLEN n_a;
2523     int unref = 0;
2524
2525     PERL_ARGS_ASSERT_SV_XMLPEEK;
2526
2527     sv_utf8_upgrade(t);
2528     sv_setpvs(t, "");
2529     /* retry: */
2530     if (!sv) {
2531         sv_catpv(t, "VOID=\"\"");
2532         goto finish;
2533     }
2534     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2535         sv_catpv(t, "WILD=\"\"");
2536         goto finish;
2537     }
2538     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2539         if (sv == &PL_sv_undef) {
2540             sv_catpv(t, "SV_UNDEF=\"1\"");
2541             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2542                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2543                 SvREADONLY(sv))
2544                 goto finish;
2545         }
2546         else if (sv == &PL_sv_no) {
2547             sv_catpv(t, "SV_NO=\"1\"");
2548             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2549                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2550                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2551                                   SVp_POK|SVp_NOK)) &&
2552                 SvCUR(sv) == 0 &&
2553                 SvNVX(sv) == 0.0)
2554                 goto finish;
2555         }
2556         else if (sv == &PL_sv_yes) {
2557             sv_catpv(t, "SV_YES=\"1\"");
2558             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2559                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2560                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2561                                   SVp_POK|SVp_NOK)) &&
2562                 SvCUR(sv) == 1 &&
2563                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2564                 SvNVX(sv) == 1.0)
2565                 goto finish;
2566         }
2567         else {
2568             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2569             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2570                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2571                 SvREADONLY(sv))
2572                 goto finish;
2573         }
2574         sv_catpv(t, " XXX=\"\" ");
2575     }
2576     else if (SvREFCNT(sv) == 0) {
2577         sv_catpv(t, " refcnt=\"0\"");
2578         unref++;
2579     }
2580     else if (DEBUG_R_TEST_) {
2581         int is_tmp = 0;
2582         I32 ix;
2583         /* is this SV on the tmps stack? */
2584         for (ix=PL_tmps_ix; ix>=0; ix--) {
2585             if (PL_tmps_stack[ix] == sv) {
2586                 is_tmp = 1;
2587                 break;
2588             }
2589         }
2590         if (SvREFCNT(sv) > 1)
2591             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2592                     is_tmp ? "T" : "");
2593         else if (is_tmp)
2594             sv_catpv(t, " DRT=\"<T>\"");
2595     }
2596
2597     if (SvROK(sv)) {
2598         sv_catpv(t, " ROK=\"\"");
2599     }
2600     switch (SvTYPE(sv)) {
2601     default:
2602         sv_catpv(t, " FREED=\"1\"");
2603         goto finish;
2604
2605     case SVt_NULL:
2606         sv_catpv(t, " UNDEF=\"1\"");
2607         goto finish;
2608     case SVt_IV:
2609         sv_catpv(t, " IV=\"");
2610         break;
2611     case SVt_NV:
2612         sv_catpv(t, " NV=\"");
2613         break;
2614     case SVt_PV:
2615         sv_catpv(t, " PV=\"");
2616         break;
2617     case SVt_PVIV:
2618         sv_catpv(t, " PVIV=\"");
2619         break;
2620     case SVt_PVNV:
2621         sv_catpv(t, " PVNV=\"");
2622         break;
2623     case SVt_PVMG:
2624         sv_catpv(t, " PVMG=\"");
2625         break;
2626     case SVt_PVLV:
2627         sv_catpv(t, " PVLV=\"");
2628         break;
2629     case SVt_PVAV:
2630         sv_catpv(t, " AV=\"");
2631         break;
2632     case SVt_PVHV:
2633         sv_catpv(t, " HV=\"");
2634         break;
2635     case SVt_PVCV:
2636         if (CvGV(sv))
2637             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2638         else
2639             sv_catpv(t, " CV=\"()\"");
2640         goto finish;
2641     case SVt_PVGV:
2642         sv_catpv(t, " GV=\"");
2643         break;
2644     case SVt_BIND:
2645         sv_catpv(t, " BIND=\"");
2646         break;
2647     case SVt_REGEXP:
2648         sv_catpv(t, " ORANGE=\"");
2649         break;
2650     case SVt_PVFM:
2651         sv_catpv(t, " FM=\"");
2652         break;
2653     case SVt_PVIO:
2654         sv_catpv(t, " IO=\"");
2655         break;
2656     }
2657
2658     if (SvPOKp(sv)) {
2659         if (SvPVX(sv)) {
2660             sv_catxmlsv(t, sv);
2661         }
2662     }
2663     else if (SvNOKp(sv)) {
2664         STORE_NUMERIC_LOCAL_SET_STANDARD();
2665         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2666         RESTORE_NUMERIC_LOCAL();
2667     }
2668     else if (SvIOKp(sv)) {
2669         if (SvIsUV(sv))
2670             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2671         else
2672             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2673     }
2674     else
2675         sv_catpv(t, "");
2676     sv_catpv(t, "\"");
2677
2678   finish:
2679     while (unref--)
2680         sv_catpv(t, ")");
2681     return SvPV(t, n_a);
2682 }
2683
2684 void
2685 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2686 {
2687     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2688
2689     if (!pm) {
2690         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2691         return;
2692     }
2693     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2694     level++;
2695     if (PM_GETRE(pm)) {
2696         REGEXP *const r = PM_GETRE(pm);
2697         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2698         sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2699         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2700              SvPVX(tmpsv));
2701         SvREFCNT_dec(tmpsv);
2702         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2703              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2704     }
2705     else
2706         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2707     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2708         SV * const tmpsv = pm_description(pm);
2709         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2710         SvREFCNT_dec(tmpsv);
2711     }
2712
2713     level--;
2714     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2715         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2716         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2717         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2718         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2719         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2720     }
2721     else
2722         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2723 }
2724
2725 void
2726 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2727 {
2728     do_pmop_xmldump(0, PL_xmlfp, pm);
2729 }
2730
2731 void
2732 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2733 {
2734     UV      seq;
2735     int     contents = 0;
2736
2737     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2738
2739     if (!o)
2740         return;
2741     sequence(o);
2742     seq = sequence_num(o);
2743     Perl_xmldump_indent(aTHX_ level, file,
2744         "<op_%s seq=\"%"UVuf" -> ",
2745              OP_NAME(o),
2746                       seq);
2747     level++;
2748     if (o->op_next)
2749         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2750                       sequence_num(o->op_next));
2751     else
2752         PerlIO_printf(file, "DONE\"");
2753
2754     if (o->op_targ) {
2755         if (o->op_type == OP_NULL)
2756         {
2757             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2758             if (o->op_targ == OP_NEXTSTATE)
2759             {
2760                 if (CopLINE(cCOPo))
2761                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2762                                      (UV)CopLINE(cCOPo));
2763                 if (CopSTASHPV(cCOPo))
2764                     PerlIO_printf(file, " package=\"%s\"",
2765                                      CopSTASHPV(cCOPo));
2766                 if (CopLABEL(cCOPo))
2767                     PerlIO_printf(file, " label=\"%s\"",
2768                                      CopLABEL(cCOPo));
2769             }
2770         }
2771         else
2772             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2773     }
2774 #ifdef DUMPADDR
2775     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2776 #endif
2777     if (o->op_flags) {
2778         SV * const tmpsv = newSVpvs("");
2779         switch (o->op_flags & OPf_WANT) {
2780         case OPf_WANT_VOID:
2781             sv_catpv(tmpsv, ",VOID");
2782             break;
2783         case OPf_WANT_SCALAR:
2784             sv_catpv(tmpsv, ",SCALAR");
2785             break;
2786         case OPf_WANT_LIST:
2787             sv_catpv(tmpsv, ",LIST");
2788             break;
2789         default:
2790             sv_catpv(tmpsv, ",UNKNOWN");
2791             break;
2792         }
2793         if (o->op_flags & OPf_KIDS)
2794             sv_catpv(tmpsv, ",KIDS");
2795         if (o->op_flags & OPf_PARENS)
2796             sv_catpv(tmpsv, ",PARENS");
2797         if (o->op_flags & OPf_STACKED)
2798             sv_catpv(tmpsv, ",STACKED");
2799         if (o->op_flags & OPf_REF)
2800             sv_catpv(tmpsv, ",REF");
2801         if (o->op_flags & OPf_MOD)
2802             sv_catpv(tmpsv, ",MOD");
2803         if (o->op_flags & OPf_SPECIAL)
2804             sv_catpv(tmpsv, ",SPECIAL");
2805         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2806         SvREFCNT_dec(tmpsv);
2807     }
2808     if (o->op_private) {
2809         SV * const tmpsv = newSVpvs("");
2810         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2811             if (o->op_private & OPpTARGET_MY)
2812                 sv_catpv(tmpsv, ",TARGET_MY");
2813         }
2814         else if (o->op_type == OP_LEAVESUB ||
2815                  o->op_type == OP_LEAVE ||
2816                  o->op_type == OP_LEAVESUBLV ||
2817                  o->op_type == OP_LEAVEWRITE) {
2818             if (o->op_private & OPpREFCOUNTED)
2819                 sv_catpv(tmpsv, ",REFCOUNTED");
2820         }
2821         else if (o->op_type == OP_AASSIGN) {
2822             if (o->op_private & OPpASSIGN_COMMON)
2823                 sv_catpv(tmpsv, ",COMMON");
2824         }
2825         else if (o->op_type == OP_SASSIGN) {
2826             if (o->op_private & OPpASSIGN_BACKWARDS)
2827                 sv_catpv(tmpsv, ",BACKWARDS");
2828         }
2829         else if (o->op_type == OP_TRANS) {
2830             if (o->op_private & OPpTRANS_SQUASH)
2831                 sv_catpv(tmpsv, ",SQUASH");
2832             if (o->op_private & OPpTRANS_DELETE)
2833                 sv_catpv(tmpsv, ",DELETE");
2834             if (o->op_private & OPpTRANS_COMPLEMENT)
2835                 sv_catpv(tmpsv, ",COMPLEMENT");
2836             if (o->op_private & OPpTRANS_IDENTICAL)
2837                 sv_catpv(tmpsv, ",IDENTICAL");
2838             if (o->op_private & OPpTRANS_GROWS)
2839                 sv_catpv(tmpsv, ",GROWS");
2840         }
2841         else if (o->op_type == OP_REPEAT) {
2842             if (o->op_private & OPpREPEAT_DOLIST)
2843                 sv_catpv(tmpsv, ",DOLIST");
2844         }
2845         else if (o->op_type == OP_ENTERSUB ||
2846                  o->op_type == OP_RV2SV ||
2847                  o->op_type == OP_GVSV ||
2848                  o->op_type == OP_RV2AV ||
2849                  o->op_type == OP_RV2HV ||
2850                  o->op_type == OP_RV2GV ||
2851                  o->op_type == OP_AELEM ||
2852                  o->op_type == OP_HELEM )
2853         {
2854             if (o->op_type == OP_ENTERSUB) {
2855                 if (o->op_private & OPpENTERSUB_AMPER)
2856                     sv_catpv(tmpsv, ",AMPER");
2857                 if (o->op_private & OPpENTERSUB_DB)
2858                     sv_catpv(tmpsv, ",DB");
2859                 if (o->op_private & OPpENTERSUB_HASTARG)
2860                     sv_catpv(tmpsv, ",HASTARG");
2861                 if (o->op_private & OPpENTERSUB_NOPAREN)
2862                     sv_catpv(tmpsv, ",NOPAREN");
2863                 if (o->op_private & OPpENTERSUB_INARGS)
2864                     sv_catpv(tmpsv, ",INARGS");
2865                 if (o->op_private & OPpENTERSUB_NOMOD)
2866                     sv_catpv(tmpsv, ",NOMOD");
2867             }
2868             else {
2869                 switch (o->op_private & OPpDEREF) {
2870             case OPpDEREF_SV:
2871                 sv_catpv(tmpsv, ",SV");
2872                 break;
2873             case OPpDEREF_AV:
2874                 sv_catpv(tmpsv, ",AV");
2875                 break;
2876             case OPpDEREF_HV:
2877                 sv_catpv(tmpsv, ",HV");
2878                 break;
2879             }
2880                 if (o->op_private & OPpMAYBE_LVSUB)
2881                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2882             }
2883             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2884                 if (o->op_private & OPpLVAL_DEFER)
2885                     sv_catpv(tmpsv, ",LVAL_DEFER");
2886             }
2887             else {
2888                 if (o->op_private & HINT_STRICT_REFS)
2889                     sv_catpv(tmpsv, ",STRICT_REFS");
2890                 if (o->op_private & OPpOUR_INTRO)
2891                     sv_catpv(tmpsv, ",OUR_INTRO");
2892             }
2893         }
2894         else if (o->op_type == OP_CONST) {
2895             if (o->op_private & OPpCONST_BARE)
2896                 sv_catpv(tmpsv, ",BARE");
2897             if (o->op_private & OPpCONST_STRICT)
2898                 sv_catpv(tmpsv, ",STRICT");
2899             if (o->op_private & OPpCONST_ARYBASE)
2900                 sv_catpv(tmpsv, ",ARYBASE");
2901             if (o->op_private & OPpCONST_WARNING)
2902                 sv_catpv(tmpsv, ",WARNING");
2903             if (o->op_private & OPpCONST_ENTERED)
2904                 sv_catpv(tmpsv, ",ENTERED");
2905         }
2906         else if (o->op_type == OP_FLIP) {
2907             if (o->op_private & OPpFLIP_LINENUM)
2908                 sv_catpv(tmpsv, ",LINENUM");
2909         }
2910         else if (o->op_type == OP_FLOP) {
2911             if (o->op_private & OPpFLIP_LINENUM)
2912                 sv_catpv(tmpsv, ",LINENUM");
2913         }
2914         else if (o->op_type == OP_RV2CV) {
2915             if (o->op_private & OPpLVAL_INTRO)
2916                 sv_catpv(tmpsv, ",INTRO");
2917         }
2918         else if (o->op_type == OP_GV) {
2919             if (o->op_private & OPpEARLY_CV)
2920                 sv_catpv(tmpsv, ",EARLY_CV");
2921         }
2922         else if (o->op_type == OP_LIST) {
2923             if (o->op_private & OPpLIST_GUESSED)
2924                 sv_catpv(tmpsv, ",GUESSED");
2925         }
2926         else if (o->op_type == OP_DELETE) {
2927             if (o->op_private & OPpSLICE)
2928                 sv_catpv(tmpsv, ",SLICE");
2929         }
2930         else if (o->op_type == OP_EXISTS) {
2931             if (o->op_private & OPpEXISTS_SUB)
2932                 sv_catpv(tmpsv, ",EXISTS_SUB");
2933         }
2934         else if (o->op_type == OP_SORT) {
2935             if (o->op_private & OPpSORT_NUMERIC)
2936                 sv_catpv(tmpsv, ",NUMERIC");
2937             if (o->op_private & OPpSORT_INTEGER)
2938                 sv_catpv(tmpsv, ",INTEGER");
2939             if (o->op_private & OPpSORT_REVERSE)
2940                 sv_catpv(tmpsv, ",REVERSE");
2941         }
2942         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2943             if (o->op_private & OPpOPEN_IN_RAW)
2944                 sv_catpv(tmpsv, ",IN_RAW");
2945             if (o->op_private & OPpOPEN_IN_CRLF)
2946                 sv_catpv(tmpsv, ",IN_CRLF");
2947             if (o->op_private & OPpOPEN_OUT_RAW)
2948                 sv_catpv(tmpsv, ",OUT_RAW");
2949             if (o->op_private & OPpOPEN_OUT_CRLF)
2950                 sv_catpv(tmpsv, ",OUT_CRLF");
2951         }
2952         else if (o->op_type == OP_EXIT) {
2953             if (o->op_private & OPpEXIT_VMSISH)
2954                 sv_catpv(tmpsv, ",EXIT_VMSISH");
2955             if (o->op_private & OPpHUSH_VMSISH)
2956                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2957         }
2958         else if (o->op_type == OP_DIE) {
2959             if (o->op_private & OPpHUSH_VMSISH)
2960                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2961         }
2962         else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2963             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2964                 sv_catpv(tmpsv, ",FT_ACCESS");
2965             if (o->op_private & OPpFT_STACKED)
2966                 sv_catpv(tmpsv, ",FT_STACKED");
2967         }
2968         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2969             sv_catpv(tmpsv, ",INTRO");
2970         if (SvCUR(tmpsv))
2971             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2972         SvREFCNT_dec(tmpsv);
2973     }
2974
2975     switch (o->op_type) {
2976     case OP_AELEMFAST:
2977         if (o->op_flags & OPf_SPECIAL) {
2978             break;
2979         }
2980     case OP_GVSV:
2981     case OP_GV:
2982 #ifdef USE_ITHREADS
2983         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2984 #else
2985         if (cSVOPo->op_sv) {
2986             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2987             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2988             char *s;
2989             STRLEN len;
2990             ENTER;
2991             SAVEFREESV(tmpsv1);
2992             SAVEFREESV(tmpsv2);
2993             gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2994             s = SvPV(tmpsv1,len);
2995             sv_catxmlpvn(tmpsv2, s, len, 1);
2996             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2997             LEAVE;
2998         }
2999         else
3000             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3001 #endif
3002         break;
3003     case OP_CONST:
3004     case OP_HINTSEVAL:
3005     case OP_METHOD_NAMED:
3006 #ifndef USE_ITHREADS
3007         /* with ITHREADS, consts are stored in the pad, and the right pad
3008          * may not be active here, so skip */
3009         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3010 #endif
3011         break;
3012     case OP_ANONCODE:
3013         if (!contents) {
3014             contents = 1;
3015             PerlIO_printf(file, ">\n");
3016         }
3017         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3018         break;
3019     case OP_NEXTSTATE:
3020     case OP_DBSTATE:
3021         if (CopLINE(cCOPo))
3022             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3023                              (UV)CopLINE(cCOPo));
3024         if (CopSTASHPV(cCOPo))
3025             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3026                              CopSTASHPV(cCOPo));
3027         if (CopLABEL(cCOPo))
3028             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3029                              CopLABEL(cCOPo));
3030         break;
3031     case OP_ENTERLOOP:
3032         S_xmldump_attr(aTHX_ level, file, "redo=\"");
3033         if (cLOOPo->op_redoop)
3034             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3035         else
3036             PerlIO_printf(file, "DONE\"");
3037         S_xmldump_attr(aTHX_ level, file, "next=\"");
3038         if (cLOOPo->op_nextop)
3039             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3040         else
3041             PerlIO_printf(file, "DONE\"");
3042         S_xmldump_attr(aTHX_ level, file, "last=\"");
3043         if (cLOOPo->op_lastop)
3044             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3045         else
3046             PerlIO_printf(file, "DONE\"");
3047         break;
3048     case OP_COND_EXPR:
3049     case OP_RANGE:
3050     case OP_MAPWHILE:
3051     case OP_GREPWHILE:
3052     case OP_OR:
3053     case OP_AND:
3054         S_xmldump_attr(aTHX_ level, file, "other=\"");
3055         if (cLOGOPo->op_other)
3056             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3057         else
3058             PerlIO_printf(file, "DONE\"");
3059         break;
3060     case OP_LEAVE:
3061     case OP_LEAVEEVAL:
3062     case OP_LEAVESUB:
3063     case OP_LEAVESUBLV:
3064     case OP_LEAVEWRITE:
3065     case OP_SCOPE:
3066         if (o->op_private & OPpREFCOUNTED)
3067             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3068         break;
3069     default:
3070         break;
3071     }
3072
3073     if (PL_madskills && o->op_madprop) {
3074         char prevkey = '\0';
3075         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3076         const MADPROP* mp = o->op_madprop;
3077
3078         if (!contents) {
3079             contents = 1;
3080             PerlIO_printf(file, ">\n");
3081         }
3082         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3083         level++;
3084         while (mp) {
3085             char tmp = mp->mad_key;
3086             sv_setpvs(tmpsv,"\"");
3087             if (tmp)
3088                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3089             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3090                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3091             else
3092                 prevkey = tmp;
3093             sv_catpv(tmpsv, "\"");
3094             switch (mp->mad_type) {
3095             case MAD_NULL:
3096                 sv_catpv(tmpsv, "NULL");
3097                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3098                 break;
3099             case MAD_PV:
3100                 sv_catpv(tmpsv, " val=\"");
3101                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3102                 sv_catpv(tmpsv, "\"");
3103                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3104                 break;
3105             case MAD_SV:
3106                 sv_catpv(tmpsv, " val=\"");
3107                 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3108                 sv_catpv(tmpsv, "\"");
3109                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3110                 break;
3111             case MAD_OP:
3112                 if ((OP*)mp->mad_val) {
3113                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3114                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3115                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3116                 }
3117                 break;
3118             default:
3119                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3120                 break;
3121             }
3122             mp = mp->mad_next;
3123         }
3124         level--;
3125         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3126
3127         SvREFCNT_dec(tmpsv);
3128     }
3129
3130     switch (o->op_type) {
3131     case OP_PUSHRE:
3132     case OP_MATCH:
3133     case OP_QR:
3134     case OP_SUBST:
3135         if (!contents) {
3136             contents = 1;
3137             PerlIO_printf(file, ">\n");
3138         }
3139         do_pmop_xmldump(level, file, cPMOPo);
3140         break;
3141     default:
3142         break;
3143     }
3144
3145     if (o->op_flags & OPf_KIDS) {
3146         OP *kid;
3147         if (!contents) {
3148             contents = 1;
3149             PerlIO_printf(file, ">\n");
3150         }
3151         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3152             do_op_xmldump(level, file, kid);
3153     }
3154
3155     if (contents)
3156         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3157     else
3158         PerlIO_printf(file, " />\n");
3159 }
3160
3161 void
3162 Perl_op_xmldump(pTHX_ const OP *o)
3163 {
3164     PERL_ARGS_ASSERT_OP_XMLDUMP;
3165
3166     do_op_xmldump(0, PL_xmlfp, o);
3167 }
3168 #endif
3169
3170 /*
3171  * Local variables:
3172  * c-indentation-style: bsd
3173  * c-basic-offset: 4
3174  * indent-tabs-mode: t
3175  * End:
3176  *
3177  * ex: set ts=8 sts=4 sw=4 noet:
3178  */