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