dump.c

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