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