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