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