dump.c

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