dump.c

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