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