dump.c

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