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