dump.c

   1 /*    dump.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *  'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
  13  *   it has not been hard for me to read your mind and memory.'
  14  *
  15  *     [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
  16  */
  17
  18 /* This file contains utility routines to dump the contents of SV and OP
  19  * structures, as used by command-line options like -Dt and -Dx, and
  20  * by Devel::Peek.
  21  *
  22  * It also holds the debugging version of the  runops function.
  23  */
  24
  25 #include "EXTERN.h"
  26 #define PERL_IN_DUMP_C
  27 #include "perl.h"
  28 #include "regcomp.h"
  29 #include "proto.h"
  30
  31
  32 static const char* const svtypenames[SVt_LAST] = {
  33     "NULL",
  34     "BIND",
  35     "IV",
  36     "NV",
  37     "PV",
  38     "PVIV",
  39     "PVNV",
  40     "PVMG",
  41     "REGEXP",
  42     "PVGV",
  43     "PVLV",
  44     "PVAV",
  45     "PVHV",
  46     "PVCV",
  47     "PVFM",
  48     "PVIO"
  49 };
  50
  51
  52 static const char* const svshorttypenames[SVt_LAST] = {
  53     "UNDEF",
  54     "BIND",
  55     "IV",
  56     "NV",
  57     "PV",
  58     "PVIV",
  59     "PVNV",
  60     "PVMG",
  61     "REGEXP",
  62     "GV",
  63     "PVLV",
  64     "AV",
  65     "HV",
  66     "CV",
  67     "FM",
  68     "IO"
  69 };
  70
  71 struct flag_to_name {
  72     U32 flag;
  73     const char *name;
  74 };
  75
  76 static void
  77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
  78                const struct flag_to_name *const end)
  79 {
  80     do {
  81         if (flags & start->flag)
  82             sv_catpv(sv, start->name);
  83     } while (++start < end);
  84 }
  85
  86 #define append_flags(sv, f, flags) \
  87     S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
  88
  89
  90 #define Sequence PL_op_sequence
  91
  92 void
  93 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
  94 {
  95     va_list args;
  96     PERL_ARGS_ASSERT_DUMP_INDENT;
  97     va_start(args, pat);
  98     dump_vindent(level, file, pat, &args);
  99     va_end(args);
 100 }
 101
 102 void
 103 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
 104 {
 105     dVAR;
 106     PERL_ARGS_ASSERT_DUMP_VINDENT;
 107     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
 108     PerlIO_vprintf(file, pat, *args);
 109 }
 110
 111 void
 112 Perl_dump_all(pTHX)
 113 {
 114     dump_all_perl(FALSE);
 115 }
 116
 117 void
 118 Perl_dump_all_perl(pTHX_ bool justperl)
 119 {
 120
 121     dVAR;
 122     PerlIO_setlinebuf(Perl_debug_log);
 123     if (PL_main_root)
 124         op_dump(PL_main_root);
 125     dump_packsubs_perl(PL_defstash, justperl);
 126 }
 127
 128 void
 129 Perl_dump_packsubs(pTHX_ const HV *stash)
 130 {
 131     PERL_ARGS_ASSERT_DUMP_PACKSUBS;
 132     dump_packsubs_perl(stash, FALSE);
 133 }
 134
 135 void
 136 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
 137 {
 138     dVAR;
 139     I32 i;
 140
 141     PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
 142
 143     if (!HvARRAY(stash))
 144         return;
 145     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 146         const HE *entry;
 147         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 148             const GV * const gv = (const GV *)HeVAL(entry);
 149             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 150                 continue;
 151             if (GvCVu(gv))
 152                 dump_sub_perl(gv, justperl);
 153             if (GvFORM(gv))
 154                 dump_form(gv);
 155             if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
 156                 const HV * const hv = GvHV(gv);
 157                 if (hv && (hv != PL_defstash))
 158                     dump_packsubs_perl(hv, justperl); /* nested package */
 159             }
 160         }
 161     }
 162 }
 163
 164 void
 165 Perl_dump_sub(pTHX_ const GV *gv)
 166 {
 167     PERL_ARGS_ASSERT_DUMP_SUB;
 168     dump_sub_perl(gv, FALSE);
 169 }
 170
 171 void
 172 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
 173 {
 174     SV * sv;
 175
 176     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
 177
 178     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
 179         return;
 180
 181     sv = sv_newmortal();
 182     gv_fullname3(sv, gv, NULL);
 183     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
 184     if (CvISXSUB(GvCV(gv)))
 185         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
 186             PTR2UV(CvXSUB(GvCV(gv))),
 187             (int)CvXSUBANY(GvCV(gv)).any_i32);
 188     else if (CvROOT(GvCV(gv)))
 189         op_dump(CvROOT(GvCV(gv)));
 190     else
 191         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 192 }
 193
 194 void
 195 Perl_dump_form(pTHX_ const GV *gv)
 196 {
 197     SV * const sv = sv_newmortal();
 198
 199     PERL_ARGS_ASSERT_DUMP_FORM;
 200
 201     gv_fullname3(sv, gv, NULL);
 202     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
 203     if (CvROOT(GvFORM(gv)))
 204         op_dump(CvROOT(GvFORM(gv)));
 205     else
 206         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 207 }
 208
 209 void
 210 Perl_dump_eval(pTHX)
 211 {
 212     dVAR;
 213     op_dump(PL_eval_root);
 214 }
 215
 216
 217 /*
 218 =for apidoc pv_escape
 219
 220 Escapes at most the first "count" chars of pv and puts the results into
 221 dsv such that the size of the escaped string will not exceed "max" chars
 222 and will not contain any incomplete escape sequences.
 223
 224 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
 225 will also be escaped.
 226
 227 Normally the SV will be cleared before the escaped string is prepared,
 228 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
 229
 230 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
 231 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
 232 using C<is_utf8_string()> to determine if it is Unicode.
 233
 234 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
 235 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
 236 chars above 127 will be escaped using this style; otherwise, only chars above
 237 255 will be so escaped; other non printable chars will use octal or
 238 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
 239 then all chars below 255 will be treated as printable and
 240 will be output as literals.
 241
 242 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
 243 string will be escaped, regardless of max. If the output is to be in hex,
 244 then it will be returned as a plain hex
 245 sequence. Thus the output will either be a single char,
 246 an octal escape sequence, a special escape like C<\n> or a hex value.
 247
 248 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
 249 not a '\\'. This is because regexes very often contain backslashed
 250 sequences, whereas '%' is not a particularly common character in patterns.
 251
 252 Returns a pointer to the escaped text as held by dsv.
 253
 254 =cut
 255 */
 256 #define PV_ESCAPE_OCTBUFSIZE 32
 257
 258 char *
 259 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
 260                 const STRLEN count, const STRLEN max,
 261                 STRLEN * const escaped, const U32 flags )
 262 {
 263     const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
 264     const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
 265     char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
 266     STRLEN wrote = 0;    /* chars written so far */
 267     STRLEN chsize = 0;   /* size of data to be written */
 268     STRLEN readsize = 1; /* size of data just read */
 269     bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
 270     const char *pv  = str;
 271     const char * const end = pv + count; /* end of string */
 272     octbuf[0] = esc;
 273
 274     PERL_ARGS_ASSERT_PV_ESCAPE;
 275
 276     if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
 277             /* This won't alter the UTF-8 flag */
 278             sv_setpvs(dsv, "");
 279     }
 280
 281     if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
 282         isuni = 1;
 283
 284     for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
 285         const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
 286         const U8 c = (U8)u & 0xFF;
 287
 288         if ( ( u > 255 )
 289           || (flags & PERL_PV_ESCAPE_ALL)
 290           || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
 291         {
 292             if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
 293                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 294                                       "%"UVxf, u);
 295             else
 296                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 297                                       "%cx{%"UVxf"}", esc, u);
 298         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
 299             chsize = 1;
 300         } else {
 301             if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
 302                 chsize = 2;
 303                 switch (c) {
 304
 305                 case '\\' : /* fallthrough */
 306                 case '%'  : if ( c == esc )  {
 307                                 octbuf[1] = esc;
 308                             } else {
 309                                 chsize = 1;
 310                             }
 311                             break;
 312                 case '\v' : octbuf[1] = 'v';  break;
 313                 case '\t' : octbuf[1] = 't';  break;
 314                 case '\r' : octbuf[1] = 'r';  break;
 315                 case '\n' : octbuf[1] = 'n';  break;
 316                 case '\f' : octbuf[1] = 'f';  break;
 317                 case '"'  :
 318                         if ( dq == '"' )
 319                                 octbuf[1] = '"';
 320                         else
 321                             chsize = 1;
 322                         break;
 323                 default:
 324                         if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
 325                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 326                                                   "%c%03o", esc, c);
 327                         else
 328                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 329                                                   "%c%o", esc, c);
 330                 }
 331             } else {
 332                 chsize = 1;
 333             }
 334         }
 335         if ( max && (wrote + chsize > max) ) {
 336             break;
 337         } else if (chsize > 1) {
 338             sv_catpvn(dsv, octbuf, chsize);
 339             wrote += chsize;
 340         } else {
 341             /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
 342                128-255 can be appended raw to the dsv. If dsv happens to be
 343                UTF-8 then we need catpvf to upgrade them for us.
 344                Or add a new API call sv_catpvc(). Think about that name, and
 345                how to keep it clear that it's unlike the s of catpvs, which is
 346                really an array octets, not a string.  */
 347             Perl_sv_catpvf( aTHX_ dsv, "%c", c);
 348             wrote++;
 349         }
 350         if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
 351             break;
 352     }
 353     if (escaped != NULL)
 354         *escaped= pv - str;
 355     return SvPVX(dsv);
 356 }
 357 /*
 358 =for apidoc pv_pretty
 359
 360 Converts a string into something presentable, handling escaping via
 361 pv_escape() and supporting quoting and ellipses.
 362
 363 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
 364 double quoted with any double quotes in the string escaped. Otherwise
 365 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
 366 angle brackets.
 367
 368 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
 369 string were output then an ellipsis C<...> will be appended to the
 370 string. Note that this happens AFTER it has been quoted.
 371
 372 If start_color is non-null then it will be inserted after the opening
 373 quote (if there is one) but before the escaped text. If end_color
 374 is non-null then it will be inserted after the escaped text but before
 375 any quotes or ellipses.
 376
 377 Returns a pointer to the prettified text as held by dsv.
 378
 379 =cut
 380 */
 381
 382 char *
 383 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
 384   const STRLEN max, char const * const start_color, char const * const end_color,
 385   const U32 flags )
 386 {
 387     const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
 388     STRLEN escaped;
 389
 390     PERL_ARGS_ASSERT_PV_PRETTY;
 391
 392     if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
 393             /* This won't alter the UTF-8 flag */
 394             sv_setpvs(dsv, "");
 395     }
 396
 397     if ( dq == '"' )
 398         sv_catpvs(dsv, "\"");
 399     else if ( flags & PERL_PV_PRETTY_LTGT )
 400         sv_catpvs(dsv, "<");
 401
 402     if ( start_color != NULL )
 403         sv_catpv(dsv, start_color);
 404
 405     pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
 406
 407     if ( end_color != NULL )
 408         sv_catpv(dsv, end_color);
 409
 410     if ( dq == '"' )
 411         sv_catpvs( dsv, "\"");
 412     else if ( flags & PERL_PV_PRETTY_LTGT )
 413         sv_catpvs(dsv, ">");
 414
 415     if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
 416             sv_catpvs(dsv, "...");
 417
 418     return SvPVX(dsv);
 419 }
 420
 421 /*
 422 =for apidoc pv_display
 423
 424 Similar to
 425
 426   pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
 427
 428 except that an additional "\0" will be appended to the string when
 429 len > cur and pv[cur] is "\0".
 430
 431 Note that the final string may be up to 7 chars longer than pvlim.
 432
 433 =cut
 434 */
 435
 436 char *
 437 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
 438 {
 439     PERL_ARGS_ASSERT_PV_DISPLAY;
 440
 441     pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
 442     if (len > cur && pv[cur] == '\0')
 443             sv_catpvs( dsv, "\\0");
 444     return SvPVX(dsv);
 445 }
 446
 447 char *
 448 Perl_sv_peek(pTHX_ SV *sv)
 449 {
 450     dVAR;
 451     SV * const t = sv_newmortal();
 452     int unref = 0;
 453     U32 type;
 454
 455     sv_setpvs(t, "");
 456   retry:
 457     if (!sv) {
 458         sv_catpv(t, "VOID");
 459         goto finish;
 460     }
 461     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
 462         sv_catpv(t, "WILD");
 463         goto finish;
 464     }
 465     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
 466         if (sv == &PL_sv_undef) {
 467             sv_catpv(t, "SV_UNDEF");
 468             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 469                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 470                 SvREADONLY(sv))
 471                 goto finish;
 472         }
 473         else if (sv == &PL_sv_no) {
 474             sv_catpv(t, "SV_NO");
 475             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 476                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 477                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 478                                   SVp_POK|SVp_NOK)) &&
 479                 SvCUR(sv) == 0 &&
 480                 SvNVX(sv) == 0.0)
 481                 goto finish;
 482         }
 483         else if (sv == &PL_sv_yes) {
 484             sv_catpv(t, "SV_YES");
 485             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 486                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 487                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 488                                   SVp_POK|SVp_NOK)) &&
 489                 SvCUR(sv) == 1 &&
 490                 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
 491                 SvNVX(sv) == 1.0)
 492                 goto finish;
 493         }
 494         else {
 495             sv_catpv(t, "SV_PLACEHOLDER");
 496             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 497                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 498                 SvREADONLY(sv))
 499                 goto finish;
 500         }
 501         sv_catpv(t, ":");
 502     }
 503     else if (SvREFCNT(sv) == 0) {
 504         sv_catpv(t, "(");
 505         unref++;
 506     }
 507     else if (DEBUG_R_TEST_) {
 508         int is_tmp = 0;
 509         I32 ix;
 510         /* is this SV on the tmps stack? */
 511         for (ix=PL_tmps_ix; ix>=0; ix--) {
 512             if (PL_tmps_stack[ix] == sv) {
 513                 is_tmp = 1;
 514                 break;
 515             }
 516         }
 517         if (SvREFCNT(sv) > 1)
 518             Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
 519                     is_tmp ? "T" : "");
 520         else if (is_tmp)
 521             sv_catpv(t, "<T>");
 522     }
 523
 524     if (SvROK(sv)) {
 525         sv_catpv(t, "\\");
 526         if (SvCUR(t) + unref > 10) {
 527             SvCUR_set(t, unref + 3);
 528             *SvEND(t) = '\0';
 529             sv_catpv(t, "...");
 530             goto finish;
 531         }
 532         sv = SvRV(sv);
 533         goto retry;
 534     }
 535     type = SvTYPE(sv);
 536     if (type == SVt_PVCV) {
 537         Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
 538         goto finish;
 539     } else if (type < SVt_LAST) {
 540         sv_catpv(t, svshorttypenames[type]);
 541
 542         if (type == SVt_NULL)
 543             goto finish;
 544     } else {
 545         sv_catpv(t, "FREED");
 546         goto finish;
 547     }
 548
 549     if (SvPOKp(sv)) {
 550         if (!SvPVX_const(sv))
 551             sv_catpv(t, "(null)");
 552         else {
 553             SV * const tmp = newSVpvs("");
 554             sv_catpv(t, "(");
 555             if (SvOOK(sv)) {
 556                 STRLEN delta;
 557                 SvOOK_offset(sv, delta);
 558                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
 559             }
 560             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
 561             if (SvUTF8(sv))
 562                 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
 563                                sv_uni_display(tmp, sv, 6 * SvCUR(sv),
 564                                               UNI_DISPLAY_QQ));
 565             SvREFCNT_dec(tmp);
 566         }
 567     }
 568     else if (SvNOKp(sv)) {
 569         STORE_NUMERIC_LOCAL_SET_STANDARD();
 570         Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
 571         RESTORE_NUMERIC_LOCAL();
 572     }
 573     else if (SvIOKp(sv)) {
 574         if (SvIsUV(sv))
 575             Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
 576         else
 577             Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
 578     }
 579     else
 580         sv_catpv(t, "()");
 581
 582   finish:
 583     while (unref--)
 584         sv_catpv(t, ")");
 585     if (PL_tainting && SvTAINTED(sv))
 586         sv_catpv(t, " [tainted]");
 587     return SvPV_nolen(t);
 588 }
 589
 590 void
 591 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
 592 {
 593     char ch;
 594
 595     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
 596
 597     if (!pm) {
 598         Perl_dump_indent(aTHX_ level, file, "{}\n");
 599         return;
 600     }
 601     Perl_dump_indent(aTHX_ level, file, "{\n");
 602     level++;
 603     if (pm->op_pmflags & PMf_ONCE)
 604         ch = '?';
 605     else
 606         ch = '/';
 607     if (PM_GETRE(pm))
 608         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
 609              ch, RX_PRECOMP(PM_GETRE(pm)), ch,
 610              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
 611     else
 612         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
 613     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
 614         Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
 615         op_dump(pm->op_pmreplrootu.op_pmreplroot);
 616     }
 617     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
 618         SV * const tmpsv = pm_description(pm);
 619         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 620         SvREFCNT_dec(tmpsv);
 621     }
 622
 623     Perl_dump_indent(aTHX_ level-1, file, "}\n");
 624 }
 625
 626 const struct flag_to_name pmflags_flags_names[] = {
 627     {PMf_CONST, ",CONST"},
 628     {PMf_KEEP, ",KEEP"},
 629     {PMf_GLOBAL, ",GLOBAL"},
 630     {PMf_CONTINUE, ",CONTINUE"},
 631     {PMf_RETAINT, ",RETAINT"},
 632     {PMf_EVAL, ",EVAL"},
 633     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
 634 };
 635
 636 static SV *
 637 S_pm_description(pTHX_ const PMOP *pm)
 638 {
 639     SV * const desc = newSVpvs("");
 640     const REGEXP * const regex = PM_GETRE(pm);
 641     const U32 pmflags = pm->op_pmflags;
 642
 643     PERL_ARGS_ASSERT_PM_DESCRIPTION;
 644
 645     if (pmflags & PMf_ONCE)
 646         sv_catpv(desc, ",ONCE");
 647 #ifdef USE_ITHREADS
 648     if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
 649         sv_catpv(desc, ":USED");
 650 #else
 651     if (pmflags & PMf_USED)
 652         sv_catpv(desc, ":USED");
 653 #endif
 654
 655     if (regex) {
 656         if (RX_EXTFLAGS(regex) & RXf_TAINTED)
 657             sv_catpv(desc, ",TAINTED");
 658         if (RX_CHECK_SUBSTR(regex)) {
 659             if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
 660                 sv_catpv(desc, ",SCANFIRST");
 661             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
 662                 sv_catpv(desc, ",ALL");
 663         }
 664         if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
 665             sv_catpv(desc, ",SKIPWHITE");
 666     }
 667
 668     append_flags(desc, pmflags, pmflags_flags_names);
 669     return desc;
 670 }
 671
 672 void
 673 Perl_pmop_dump(pTHX_ PMOP *pm)
 674 {
 675     do_pmop_dump(0, Perl_debug_log, pm);
 676 }
 677
 678 /* An op sequencer.  We visit the ops in the order they're to execute. */
 679
 680 STATIC void
 681 S_sequence(pTHX_ register const OP *o)
 682 {
 683     dVAR;
 684     const OP *oldop = NULL;
 685
 686     if (!o)
 687         return;
 688
 689 #ifdef PERL_MAD
 690     if (o->op_next == 0)
 691         return;
 692 #endif
 693
 694     if (!Sequence)
 695         Sequence = newHV();
 696
 697     for (; o; o = o->op_next) {
 698         STRLEN len;
 699         SV * const op = newSVuv(PTR2UV(o));
 700         const char * const key = SvPV_const(op, len);
 701
 702         if (hv_exists(Sequence, key, len))
 703             break;
 704
 705         switch (o->op_type) {
 706         case OP_STUB:
 707             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
 708                 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 709                 break;
 710             }
 711             goto nothin;
 712         case OP_NULL:
 713 #ifdef PERL_MAD
 714             if (o == o->op_next)
 715                 return;
 716 #endif
 717             if (oldop && o->op_next)
 718                 continue;
 719             break;
 720         case OP_SCALAR:
 721         case OP_LINESEQ:
 722         case OP_SCOPE:
 723           nothin:
 724             if (oldop && o->op_next)
 725                 continue;
 726             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 727             break;
 728
 729         case OP_MAPWHILE:
 730         case OP_GREPWHILE:
 731         case OP_AND:
 732         case OP_OR:
 733         case OP_DOR:
 734         case OP_ANDASSIGN:
 735         case OP_ORASSIGN:
 736         case OP_DORASSIGN:
 737         case OP_COND_EXPR:
 738         case OP_RANGE:
 739             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 740             sequence_tail(cLOGOPo->op_other);
 741             break;
 742
 743         case OP_ENTERLOOP:
 744         case OP_ENTERITER:
 745             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 746             sequence_tail(cLOOPo->op_redoop);
 747             sequence_tail(cLOOPo->op_nextop);
 748             sequence_tail(cLOOPo->op_lastop);
 749             break;
 750
 751         case OP_SUBST:
 752             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 753             sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
 754             break;
 755
 756         case OP_QR:
 757         case OP_MATCH:
 758         case OP_HELEM:
 759             break;
 760
 761         default:
 762             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 763             break;
 764         }
 765         oldop = o;
 766     }
 767 }
 768
 769 static void
 770 S_sequence_tail(pTHX_ const OP *o)
 771 {
 772     while (o && (o->op_type == OP_NULL))
 773         o = o->op_next;
 774     sequence(o);
 775 }
 776
 777 STATIC UV
 778 S_sequence_num(pTHX_ const OP *o)
 779 {
 780     dVAR;
 781     SV     *op,
 782           **seq;
 783     const char *key;
 784     STRLEN  len;
 785     if (!o) return 0;
 786     op = newSVuv(PTR2UV(o));
 787     key = SvPV_const(op, len);
 788     seq = hv_fetch(Sequence, key, len, 0);
 789     return seq ? SvUV(*seq): 0;
 790 }
 791
 792 const struct flag_to_name op_flags_names[] = {
 793     {OPf_KIDS, ",KIDS"},
 794     {OPf_PARENS, ",PARENS"},
 795     {OPf_REF, ",REF"},
 796     {OPf_MOD, ",MOD"},
 797     {OPf_STACKED, ",STACKED"},
 798     {OPf_SPECIAL, ",SPECIAL"}
 799 };
 800
 801 const struct flag_to_name op_trans_names[] = {
 802     {OPpTRANS_FROM_UTF, ",FROM_UTF"},
 803     {OPpTRANS_TO_UTF, ",TO_UTF"},
 804     {OPpTRANS_IDENTICAL, ",IDENTICAL"},
 805     {OPpTRANS_SQUASH, ",SQUASH"},
 806     {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
 807     {OPpTRANS_GROWS, ",GROWS"},
 808     {OPpTRANS_DELETE, ",DELETE"}
 809 };
 810
 811 const struct flag_to_name op_entersub_names[] = {
 812     {OPpENTERSUB_DB, ",DB"},
 813     {OPpENTERSUB_HASTARG, ",HASTARG"},
 814     {OPpENTERSUB_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 const struct flag_to_name regexp_flags_names[] = {
1547     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1548     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1549     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1550     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1551     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1552     {RXf_ANCH_BOL,        "ANCH_BOL,"},
1553     {RXf_ANCH_MBOL,       "ANCH_MBOL,"},
1554     {RXf_ANCH_SBOL,       "ANCH_SBOL,"},
1555     {RXf_ANCH_GPOS,       "ANCH_GPOS,"},
1556     {RXf_GPOS_SEEN,       "GPOS_SEEN,"},
1557     {RXf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1558     {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1559     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1560     {RXf_CANY_SEEN,       "CANY_SEEN,"},
1561     {RXf_NOSCAN,          "NOSCAN,"},
1562     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1563     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1564     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1565     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1566     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1567     {RXf_SPLIT,           "SPLIT,"},
1568     {RXf_COPY_DONE,       "COPY_DONE,"},
1569     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1570     {RXf_TAINTED,         "TAINTED,"},
1571     {RXf_START_ONLY,      "START_ONLY,"},
1572     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1573     {RXf_WHITE,           "WHITE,"},
1574     {RXf_NULL,            "NULL,"},
1575 };
1576
1577 void
1578 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1579 {
1580     dVAR;
1581     SV *d;
1582     const char *s;
1583     U32 flags;
1584     U32 type;
1585
1586     PERL_ARGS_ASSERT_DO_SV_DUMP;
1587
1588     if (!sv) {
1589         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1590         return;
1591     }
1592
1593     flags = SvFLAGS(sv);
1594     type = SvTYPE(sv);
1595
1596     /* process general SV flags */
1597
1598     d = Perl_newSVpvf(aTHX_
1599                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1600                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1601                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1602                    (int)(PL_dumpindent*level), "");
1603
1604     if (!((flags & SVpad_NAME) == SVpad_NAME
1605           && (type == SVt_PVMG || type == SVt_PVNV))) {
1606         if (flags & SVs_PADSTALE)       sv_catpv(d, "PADSTALE,");
1607     }
1608     if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1609         if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1610         if (flags & SVs_PADMY)  sv_catpv(d, "PADMY,");
1611     }
1612     append_flags(d, flags, first_sv_flags_names);
1613     if (flags & SVf_ROK)  {
1614                                 sv_catpv(d, "ROK,");
1615         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1616     }
1617     append_flags(d, flags, second_sv_flags_names);
1618     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1619         if (SvPCS_IMPORTED(sv))
1620                                 sv_catpv(d, "PCS_IMPORTED,");
1621         else
1622                                 sv_catpv(d, "SCREAM,");
1623     }
1624
1625     /* process type-specific SV flags */
1626
1627     switch (type) {
1628     case SVt_PVCV:
1629     case SVt_PVFM:
1630         append_flags(d, CvFLAGS(sv), cv_flags_names);
1631         break;
1632     case SVt_PVHV:
1633         append_flags(d, flags, hv_flags_names);
1634         break;
1635     case SVt_PVGV:
1636     case SVt_PVLV:
1637         if (isGV_with_GP(sv)) {
1638             append_flags(d, GvFLAGS(sv), gp_flags_names);
1639         }
1640         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1641             sv_catpv(d, "IMPORT");
1642             if (GvIMPORTED(sv) == GVf_IMPORTED)
1643                 sv_catpv(d, "ALL,");
1644             else {
1645                 sv_catpv(d, "(");
1646                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1647                 sv_catpv(d, " ),");
1648             }
1649         }
1650         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1651         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1652         /* FALL THROUGH */
1653     default:
1654     evaled_or_uv:
1655         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1656         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1657         break;
1658     case SVt_PVMG:
1659         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1660         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1661         /* FALL THROUGH */
1662     case SVt_PVNV:
1663         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1664         goto evaled_or_uv;
1665     case SVt_PVAV:
1666         break;
1667     }
1668     /* SVphv_SHAREKEYS is also 0x20000000 */
1669     if ((type != SVt_PVHV) && SvUTF8(sv))
1670         sv_catpv(d, "UTF8");
1671
1672     if (*(SvEND(d) - 1) == ',') {
1673         SvCUR_set(d, SvCUR(d) - 1);
1674         SvPVX(d)[SvCUR(d)] = '\0';
1675     }
1676     sv_catpv(d, ")");
1677     s = SvPVX_const(d);
1678
1679     /* dump initial SV details */
1680
1681 #ifdef DEBUG_LEAKING_SCALARS
1682     Perl_dump_indent(aTHX_ level, file,
1683         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1684         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1685         sv->sv_debug_line,
1686         sv->sv_debug_inpad ? "for" : "by",
1687         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1688         PTR2UV(sv->sv_debug_parent),
1689         sv->sv_debug_serial
1690     );
1691 #endif
1692     Perl_dump_indent(aTHX_ level, file, "SV = ");
1693
1694     /* Dump SV type */
1695
1696     if (type < SVt_LAST) {
1697         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1698
1699         if (type ==  SVt_NULL) {
1700             SvREFCNT_dec(d);
1701             return;
1702         }
1703     } else {
1704         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1705         SvREFCNT_dec(d);
1706         return;
1707     }
1708
1709     /* Dump general SV fields */
1710
1711     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1712          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1713          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1714         || (type == SVt_IV && !SvROK(sv))) {
1715         if (SvIsUV(sv)
1716 #ifdef PERL_OLD_COPY_ON_WRITE
1717                        || SvIsCOW(sv)
1718 #endif
1719                                      )
1720             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1721         else
1722             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1723 #ifdef PERL_OLD_COPY_ON_WRITE
1724         if (SvIsCOW_shared_hash(sv))
1725             PerlIO_printf(file, "  (HASH)");
1726         else if (SvIsCOW_normal(sv))
1727             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1728 #endif
1729         PerlIO_putc(file, '\n');
1730     }
1731
1732     if ((type == SVt_PVNV || type == SVt_PVMG)
1733         && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1734         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1735                          (UV) COP_SEQ_RANGE_LOW(sv));
1736         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1737                          (UV) COP_SEQ_RANGE_HIGH(sv));
1738     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1739                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1740                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1741                || type == SVt_NV) {
1742         STORE_NUMERIC_LOCAL_SET_STANDARD();
1743         /* %Vg doesn't work? --jhi */
1744 #ifdef USE_LONG_DOUBLE
1745         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1746 #else
1747         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1748 #endif
1749         RESTORE_NUMERIC_LOCAL();
1750     }
1751
1752     if (SvROK(sv)) {
1753         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1754         if (nest < maxnest)
1755             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1756     }
1757
1758     if (type < SVt_PV) {
1759         SvREFCNT_dec(d);
1760         return;
1761     }
1762
1763     if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1764         if (SvPVX_const(sv)) {
1765             STRLEN delta;
1766             if (SvOOK(sv)) {
1767                 SvOOK_offset(sv, delta);
1768                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1769                                  (UV) delta);
1770             } else {
1771                 delta = 0;
1772             }
1773             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1774             if (SvOOK(sv)) {
1775                 PerlIO_printf(file, "( %s . ) ",
1776                               pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1777                                          pvlim));
1778             }
1779             PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1780             if (SvUTF8(sv)) /* the 6?  \x{....} */
1781                 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1782             PerlIO_printf(file, "\n");
1783             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1784             Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
1785         }
1786         else
1787             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1788     }
1789
1790     if (type >= SVt_PVMG) {
1791         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1792             HV * const ost = SvOURSTASH(sv);
1793             if (ost)
1794                 do_hv_dump(level, file, "  OURSTASH", ost);
1795         } else {
1796             if (SvMAGIC(sv))
1797                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1798         }
1799         if (SvSTASH(sv))
1800             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1801     }
1802
1803     /* Dump type-specific SV fields */
1804
1805     switch (type) {
1806     case SVt_PVAV:
1807         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1808         if (AvARRAY(sv) != AvALLOC(sv)) {
1809             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1810             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1811         }
1812         else
1813             PerlIO_putc(file, '\n');
1814         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1815         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1816         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1817         sv_setpvs(d, "");
1818         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1819         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1820         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1821                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1822         if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1823             int count;
1824             for (count = 0; count <=  av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1825                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1826
1827                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1828                 if (elt)
1829                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1830             }
1831         }
1832         break;
1833     case SVt_PVHV:
1834         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1835         if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1836             /* Show distribution of HEs in the ARRAY */
1837             int freq[200];
1838 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1839             int i;
1840             int max = 0;
1841             U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1842             NV theoret, sum = 0;
1843
1844             PerlIO_printf(file, "  (");
1845             Zero(freq, FREQ_MAX + 1, int);
1846             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1847                 HE* h;
1848                 int count = 0;
1849                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1850                     count++;
1851                 if (count > FREQ_MAX)
1852                     count = FREQ_MAX;
1853                 freq[count]++;
1854                 if (max < count)
1855                     max = count;
1856             }
1857             for (i = 0; i <= max; i++) {
1858                 if (freq[i]) {
1859                     PerlIO_printf(file, "%d%s:%d", i,
1860                                   (i == FREQ_MAX) ? "+" : "",
1861                                   freq[i]);
1862                     if (i != max)
1863                         PerlIO_printf(file, ", ");
1864                 }
1865             }
1866             PerlIO_putc(file, ')');
1867             /* The "quality" of a hash is defined as the total number of
1868                comparisons needed to access every element once, relative
1869                to the expected number needed for a random hash.
1870
1871                The total number of comparisons is equal to the sum of
1872                the squares of the number of entries in each bucket.
1873                For a random hash of n keys into k buckets, the expected
1874                value is
1875                                 n + n(n-1)/2k
1876             */
1877
1878             for (i = max; i > 0; i--) { /* Precision: count down. */
1879                 sum += freq[i] * i * i;
1880             }
1881             while ((keys = keys >> 1))
1882                 pow2 = pow2 << 1;
1883             theoret = HvUSEDKEYS(sv);
1884             theoret += theoret * (theoret-1)/pow2;
1885             PerlIO_putc(file, '\n');
1886             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1887         }
1888         PerlIO_putc(file, '\n');
1889         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1890         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1891         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1892         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1893         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1894         {
1895             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1896             if (mg && mg->mg_obj) {
1897                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1898             }
1899         }
1900         {
1901             const char * const hvname = HvNAME_get(sv);
1902             if (hvname)
1903                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1904         }
1905         if (SvOOK(sv)) {
1906             AV * const backrefs
1907                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1908             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1909             if (HvAUX(sv)->xhv_name_count)
1910                 Perl_dump_indent(aTHX_
1911                  level, file, "  NAMECOUNT = %"IVdf"\n",
1912                  (IV)HvAUX(sv)->xhv_name_count
1913                 );
1914             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1915                 const I32 count = HvAUX(sv)->xhv_name_count;
1916                 if (count) {
1917                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1918                     /* The starting point is the first element if count is
1919                        positive and the second element if count is negative. */
1920                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1921                         + (count < 0 ? 1 : 0);
1922                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1923                         + (count < 0 ? -count : count);
1924                     while (hekp < endp) {
1925                         if (*hekp) {
1926                             sv_catpvs(names, ", \"");
1927                             sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1928                             sv_catpvs(names, "\"");
1929                         } else {
1930                             /* This should never happen. */
1931                             sv_catpvs(names, ", (null)");
1932                         }
1933                         ++hekp;
1934                     }
1935                     Perl_dump_indent(aTHX_
1936                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1937                     );
1938                 }
1939                 else
1940                     Perl_dump_indent(aTHX_
1941                      level, file, "  ENAME = \"%s\"\n", HvENAME_get(sv)
1942                     );
1943             }
1944             if (backrefs) {
1945                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1946                                  PTR2UV(backrefs));
1947                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1948                            dumpops, pvlim);
1949             }
1950             if (meta) {
1951                 /* FIXME - mro_algs kflags can signal a UTF-8 name.  */
1952                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1953                                  (int)meta->mro_which->length,
1954                                  meta->mro_which->name,
1955                                  PTR2UV(meta->mro_which));
1956                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1957                                  (UV)meta->cache_gen);
1958                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1959                                  (UV)meta->pkg_gen);
1960                 if (meta->mro_linear_all) {
1961                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1962                                  PTR2UV(meta->mro_linear_all));
1963                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1964                            dumpops, pvlim);
1965                 }
1966                 if (meta->mro_linear_current) {
1967                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1968                                  PTR2UV(meta->mro_linear_current));
1969                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1970                            dumpops, pvlim);
1971                 }
1972                 if (meta->mro_nextmethod) {
1973                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1974                                  PTR2UV(meta->mro_nextmethod));
1975                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1976                            dumpops, pvlim);
1977                 }
1978                 if (meta->isa) {
1979                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1980                                  PTR2UV(meta->isa));
1981                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1982                            dumpops, pvlim);
1983                 }
1984             }
1985         }
1986         if (nest < maxnest) {
1987             if (HvEITER_get(sv)) /* preserve iterator */
1988                 Perl_dump_indent(aTHX_ level, file,
1989                     "  (*** Active iterator; skipping element dump ***)\n");
1990             else {
1991                 HE *he;
1992                 HV * const hv = MUTABLE_HV(sv);
1993                 int count = maxnest - nest;
1994
1995                 hv_iterinit(hv);
1996                 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1997                        && count--) {
1998                     STRLEN len;
1999                     const U32 hash = HeHASH(he);
2000                     SV * const keysv = hv_iterkeysv(he);
2001                     const char * const keypv = SvPV_const(keysv, len);
2002                     SV * const elt = hv_iterval(hv, he);
2003
2004                     Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2005                     if (SvUTF8(keysv))
2006                         PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
2007                     if (HeKREHASH(he))
2008                         PerlIO_printf(file, "[REHASH] ");
2009                     PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
2010                     do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2011                 }
2012                 hv_iterinit(hv);                /* Return to status quo */
2013             }
2014         }
2015         break;
2016
2017     case SVt_PVCV:
2018         if (SvPOK(sv)) {
2019             STRLEN len;
2020             const char *const proto =  SvPV_const(sv, len);
2021             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
2022                              (int) len, proto);
2023         }
2024         /* FALL THROUGH */
2025     case SVt_PVFM:
2026         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
2027         if (!CvISXSUB(sv)) {
2028             if (CvSTART(sv)) {
2029                 Perl_dump_indent(aTHX_ level, file,
2030                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
2031                                  PTR2UV(CvSTART(sv)),
2032                                  (IV)sequence_num(CvSTART(sv)));
2033             }
2034             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
2035                              PTR2UV(CvROOT(sv)));
2036             if (CvROOT(sv) && dumpops) {
2037                 do_op_dump(level+1, file, CvROOT(sv));
2038             }
2039         } else {
2040             SV * const constant = cv_const_sv((const CV *)sv);
2041
2042             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
2043
2044             if (constant) {
2045                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
2046                                  " (CONST SV)\n",
2047                                  PTR2UV(CvXSUBANY(sv).any_ptr));
2048                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2049                            pvlim);
2050             } else {
2051                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
2052                                  (IV)CvXSUBANY(sv).any_i32);
2053             }
2054         }
2055         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
2056         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
2057         if (type == SVt_PVCV)
2058             Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2059         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2060         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2061         if (type == SVt_PVFM)
2062             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
2063         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2064         if (nest < maxnest) {
2065             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2066         }
2067         {
2068             const CV * const outside = CvOUTSIDE(sv);
2069             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
2070                         PTR2UV(outside),
2071                         (!outside ? "null"
2072                          : CvANON(outside) ? "ANON"
2073                          : (outside == PL_main_cv) ? "MAIN"
2074                          : CvUNIQUE(outside) ? "UNIQUE"
2075                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2076         }
2077         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2078             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2079         break;
2080
2081     case SVt_PVGV:
2082     case SVt_PVLV:
2083         if (type == SVt_PVLV) {
2084             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2085             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2086             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2087             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2088             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2089                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2090                     dumpops, pvlim);
2091         }
2092         if (SvVALID(sv)) {
2093             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %u\n", (U8)BmFLAGS(sv));
2094             Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
2095             Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
2096             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
2097         }
2098         if (!isGV_with_GP(sv))
2099             break;
2100         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
2101         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2102         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2103         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2104         if (!GvGP(sv))
2105             break;
2106         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2107         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2108         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2109         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2110         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2111         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2112         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2113         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2114         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2115         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2116         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2117         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2118         break;
2119     case SVt_PVIO:
2120         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2121         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2122         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2123         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2124         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2125         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2126         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2127         if (IoTOP_NAME(sv))
2128             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2129         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2130             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2131         else {
2132             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2133                              PTR2UV(IoTOP_GV(sv)));
2134             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2135                         maxnest, dumpops, pvlim);
2136         }
2137         /* Source filters hide things that are not GVs in these three, so let's
2138            be careful out there.  */
2139         if (IoFMT_NAME(sv))
2140             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2141         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2142             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2143         else {
2144             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2145                              PTR2UV(IoFMT_GV(sv)));
2146             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2147                         maxnest, dumpops, pvlim);
2148         }
2149         if (IoBOTTOM_NAME(sv))
2150             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2151         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2152             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2153         else {
2154             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2155                              PTR2UV(IoBOTTOM_GV(sv)));
2156             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2157                         maxnest, dumpops, pvlim);
2158         }
2159         if (isPRINT(IoTYPE(sv)))
2160             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2161         else
2162             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2163         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2164         break;
2165     case SVt_REGEXP:
2166         {
2167             struct regexp * const r = (struct regexp *)SvANY(sv);
2168             flags = RX_EXTFLAGS((REGEXP*)sv);
2169             sv_setpv(d,"");
2170             append_flags(d, flags, regexp_flags_names);
2171             if (*(SvEND(d) - 1) == ',') {
2172                 SvCUR_set(d, SvCUR(d) - 1);
2173                 SvPVX(d)[SvCUR(d)] = '\0';
2174             }
2175             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2176                                 (UV)flags, SvPVX_const(d));
2177             Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2178                                 (UV)(r->intflags));
2179             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2180                                 (UV)(r->nparens));
2181             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2182                                 (UV)(r->lastparen));
2183             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2184                                 (UV)(r->lastcloseparen));
2185             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2186                                 (IV)(r->minlen));
2187             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2188                                 (IV)(r->minlenret));
2189             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2190                                 (UV)(r->gofs));
2191             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2192                                 (UV)(r->pre_prefix));
2193             Perl_dump_indent(aTHX_ level, file, "  SEEN_EVALS = %"UVuf"\n",
2194                                 (UV)(r->seen_evals));
2195             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2196                                 (IV)(r->sublen));
2197             if (r->subbeg)
2198                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2199                             PTR2UV(r->subbeg),
2200                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2201             else
2202                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2203             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf"\n",
2204                                 PTR2UV(r->engine));
2205             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2206                                 PTR2UV(r->mother_re));
2207             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2208                                 PTR2UV(r->paren_names));
2209             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2210                                 PTR2UV(r->substrs));
2211             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2212                                 PTR2UV(r->pprivate));
2213             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2214                                 PTR2UV(r->offs));
2215 #ifdef PERL_OLD_COPY_ON_WRITE
2216             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2217                                 PTR2UV(r->saved_copy));
2218 #endif
2219         }
2220         break;
2221     }
2222     SvREFCNT_dec(d);
2223 }
2224
2225 void
2226 Perl_sv_dump(pTHX_ SV *sv)
2227 {
2228     dVAR;
2229
2230     PERL_ARGS_ASSERT_SV_DUMP;
2231
2232     if (SvROK(sv))
2233         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2234     else
2235         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2236 }
2237
2238 int
2239 Perl_runops_debug(pTHX)
2240 {
2241     dVAR;
2242     if (!PL_op) {
2243         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2244         return 0;
2245     }
2246
2247     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2248     do {
2249         if (PL_debug) {
2250             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2251                 PerlIO_printf(Perl_debug_log,
2252                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2253                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2254                               PTR2UV(*PL_watchaddr));
2255             if (DEBUG_s_TEST_) {
2256                 if (DEBUG_v_TEST_) {
2257                     PerlIO_printf(Perl_debug_log, "\n");
2258                     deb_stack_all();
2259                 }
2260                 else
2261                     debstack();
2262             }
2263
2264
2265             if (DEBUG_t_TEST_) debop(PL_op);
2266             if (DEBUG_P_TEST_) debprof(PL_op);
2267         }
2268     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2269     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2270
2271     TAINT_NOT;
2272     return 0;
2273 }
2274
2275 I32
2276 Perl_debop(pTHX_ const OP *o)
2277 {
2278     dVAR;
2279
2280     PERL_ARGS_ASSERT_DEBOP;
2281
2282     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2283         return 0;
2284
2285     Perl_deb(aTHX_ "%s", OP_NAME(o));
2286     switch (o->op_type) {
2287     case OP_CONST:
2288     case OP_HINTSEVAL:
2289         /* With ITHREADS, consts are stored in the pad, and the right pad
2290          * may not be active here, so check.
2291          * Looks like only during compiling the pads are illegal.
2292          */
2293 #ifdef USE_ITHREADS
2294         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2295 #endif
2296             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2297         break;
2298     case OP_GVSV:
2299     case OP_GV:
2300         if (cGVOPo_gv) {
2301             SV * const sv = newSV(0);
2302 #ifdef PERL_MAD
2303             /* FIXME - is this making unwarranted assumptions about the
2304                UTF-8 cleanliness of the dump file handle?  */
2305             SvUTF8_on(sv);
2306 #endif
2307             gv_fullname3(sv, cGVOPo_gv, NULL);
2308             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2309             SvREFCNT_dec(sv);
2310         }
2311         else
2312             PerlIO_printf(Perl_debug_log, "(NULL)");
2313         break;
2314     case OP_PADSV:
2315     case OP_PADAV:
2316     case OP_PADHV:
2317         {
2318         /* print the lexical's name */
2319         CV * const cv = deb_curcv(cxstack_ix);
2320         SV *sv;
2321         if (cv) {
2322             AV * const padlist = CvPADLIST(cv);
2323             AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2324             sv = *av_fetch(comppad, o->op_targ, FALSE);
2325         } else
2326             sv = NULL;
2327         if (sv)
2328             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2329         else
2330             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2331         }
2332         break;
2333     default:
2334         break;
2335     }
2336     PerlIO_printf(Perl_debug_log, "\n");
2337     return 0;
2338 }
2339
2340 STATIC CV*
2341 S_deb_curcv(pTHX_ const I32 ix)
2342 {
2343     dVAR;
2344     const PERL_CONTEXT * const cx = &cxstack[ix];
2345     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2346         return cx->blk_sub.cv;
2347     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2348         return PL_compcv;
2349     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2350         return PL_main_cv;
2351     else if (ix <= 0)
2352         return NULL;
2353     else
2354         return deb_curcv(ix - 1);
2355 }
2356
2357 void
2358 Perl_watch(pTHX_ char **addr)
2359 {
2360     dVAR;
2361
2362     PERL_ARGS_ASSERT_WATCH;
2363
2364     PL_watchaddr = addr;
2365     PL_watchok = *addr;
2366     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2367         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2368 }
2369
2370 STATIC void
2371 S_debprof(pTHX_ const OP *o)
2372 {
2373     dVAR;
2374
2375     PERL_ARGS_ASSERT_DEBPROF;
2376
2377     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2378         return;
2379     if (!PL_profiledata)
2380         Newxz(PL_profiledata, MAXO, U32);
2381     ++PL_profiledata[o->op_type];
2382 }
2383
2384 void
2385 Perl_debprofdump(pTHX)
2386 {
2387     dVAR;
2388     unsigned i;
2389     if (!PL_profiledata)
2390         return;
2391     for (i = 0; i < MAXO; i++) {
2392         if (PL_profiledata[i])
2393             PerlIO_printf(Perl_debug_log,
2394                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2395                                        PL_op_name[i]);
2396     }
2397 }
2398
2399 #ifdef PERL_MAD
2400 /*
2401  *    XML variants of most of the above routines
2402  */
2403
2404 STATIC void
2405 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2406 {
2407     va_list args;
2408
2409     PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2410
2411     PerlIO_printf(file, "\n    ");
2412     va_start(args, pat);
2413     xmldump_vindent(level, file, pat, &args);
2414     va_end(args);
2415 }
2416
2417
2418 void
2419 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2420 {
2421     va_list args;
2422     PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2423     va_start(args, pat);
2424     xmldump_vindent(level, file, pat, &args);
2425     va_end(args);
2426 }
2427
2428 void
2429 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2430 {
2431     PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2432
2433     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2434     PerlIO_vprintf(file, pat, *args);
2435 }
2436
2437 void
2438 Perl_xmldump_all(pTHX)
2439 {
2440     xmldump_all_perl(FALSE);
2441 }
2442
2443 void
2444 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2445 {
2446     PerlIO_setlinebuf(PL_xmlfp);
2447     if (PL_main_root)
2448         op_xmldump(PL_main_root);
2449     /* someday we might call this, when it outputs XML: */
2450     /* xmldump_packsubs_perl(PL_defstash, justperl); */
2451     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2452         PerlIO_close(PL_xmlfp);
2453     PL_xmlfp = 0;
2454 }
2455
2456 void
2457 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2458 {
2459     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2460     xmldump_packsubs_perl(stash, FALSE);
2461 }
2462
2463 void
2464 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2465 {
2466     I32 i;
2467     HE  *entry;
2468
2469     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2470
2471     if (!HvARRAY(stash))
2472         return;
2473     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2474         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2475             GV *gv = MUTABLE_GV(HeVAL(entry));
2476             HV *hv;
2477             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2478                 continue;
2479             if (GvCVu(gv))
2480                 xmldump_sub_perl(gv, justperl);
2481             if (GvFORM(gv))
2482                 xmldump_form(gv);
2483             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2484                 && (hv = GvHV(gv)) && hv != PL_defstash)
2485                 xmldump_packsubs_perl(hv, justperl);    /* nested package */
2486         }
2487     }
2488 }
2489
2490 void
2491 Perl_xmldump_sub(pTHX_ const GV *gv)
2492 {
2493     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2494     xmldump_sub_perl(gv, FALSE);
2495 }
2496
2497 void
2498 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2499 {
2500     SV * sv;
2501
2502     PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2503
2504     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2505         return;
2506
2507     sv = sv_newmortal();
2508     gv_fullname3(sv, gv, NULL);
2509     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2510     if (CvXSUB(GvCV(gv)))
2511         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2512             PTR2UV(CvXSUB(GvCV(gv))),
2513             (int)CvXSUBANY(GvCV(gv)).any_i32);
2514     else if (CvROOT(GvCV(gv)))
2515         op_xmldump(CvROOT(GvCV(gv)));
2516     else
2517         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2518 }
2519
2520 void
2521 Perl_xmldump_form(pTHX_ const GV *gv)
2522 {
2523     SV * const sv = sv_newmortal();
2524
2525     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2526
2527     gv_fullname3(sv, gv, NULL);
2528     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2529     if (CvROOT(GvFORM(gv)))
2530         op_xmldump(CvROOT(GvFORM(gv)));
2531     else
2532         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2533 }
2534
2535 void
2536 Perl_xmldump_eval(pTHX)
2537 {
2538     op_xmldump(PL_eval_root);
2539 }
2540
2541 char *
2542 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2543 {
2544     PERL_ARGS_ASSERT_SV_CATXMLSV;
2545     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2546 }
2547
2548 char *
2549 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2550 {
2551     PERL_ARGS_ASSERT_SV_CATXMLPV;
2552     return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2553 }
2554
2555 char *
2556 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2557 {
2558     unsigned int c;
2559     const char * const e = pv + len;
2560     const char * const start = pv;
2561     STRLEN dsvcur;
2562     STRLEN cl;
2563
2564     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2565
2566     sv_catpvs(dsv,"");
2567     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2568
2569   retry:
2570     while (pv < e) {
2571         if (utf8) {
2572             c = utf8_to_uvchr((U8*)pv, &cl);
2573             if (cl == 0) {
2574                 SvCUR(dsv) = dsvcur;
2575                 pv = start;
2576                 utf8 = 0;
2577                 goto retry;
2578             }
2579         }
2580         else
2581             c = (*pv & 255);
2582
2583         switch (c) {
2584         case 0x00:
2585         case 0x01:
2586         case 0x02:
2587         case 0x03:
2588         case 0x04:
2589         case 0x05:
2590         case 0x06:
2591         case 0x07:
2592         case 0x08:
2593         case 0x0b:
2594         case 0x0c:
2595         case 0x0e:
2596         case 0x0f:
2597         case 0x10:
2598         case 0x11:
2599         case 0x12:
2600         case 0x13:
2601         case 0x14:
2602         case 0x15:
2603         case 0x16:
2604         case 0x17:
2605         case 0x18:
2606         case 0x19:
2607         case 0x1a:
2608         case 0x1b:
2609         case 0x1c:
2610         case 0x1d:
2611         case 0x1e:
2612         case 0x1f:
2613         case 0x7f:
2614         case 0x80:
2615         case 0x81:
2616         case 0x82:
2617         case 0x83:
2618         case 0x84:
2619         case 0x86:
2620         case 0x87:
2621         case 0x88:
2622         case 0x89:
2623         case 0x90:
2624         case 0x91:
2625         case 0x92:
2626         case 0x93:
2627         case 0x94:
2628         case 0x95:
2629         case 0x96:
2630         case 0x97:
2631         case 0x98:
2632         case 0x99:
2633         case 0x9a:
2634         case 0x9b:
2635         case 0x9c:
2636         case 0x9d:
2637         case 0x9e:
2638         case 0x9f:
2639             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2640             break;
2641         case '<':
2642             sv_catpvs(dsv, "&lt;");
2643             break;
2644         case '>':
2645             sv_catpvs(dsv, "&gt;");
2646             break;
2647         case '&':
2648             sv_catpvs(dsv, "&amp;");
2649             break;
2650         case '"':
2651             sv_catpvs(dsv, "&#34;");
2652             break;
2653         default:
2654             if (c < 0xD800) {
2655                 if (c < 32 || c > 127) {
2656                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2657                 }
2658                 else {
2659                     const char string = (char) c;
2660                     sv_catpvn(dsv, &string, 1);
2661                 }
2662                 break;
2663             }
2664             if ((c >= 0xD800 && c <= 0xDB7F) ||
2665                 (c >= 0xDC00 && c <= 0xDFFF) ||
2666                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2667                  c > 0x10ffff)
2668                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2669             else
2670                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2671         }
2672
2673         if (utf8)
2674             pv += UTF8SKIP(pv);
2675         else
2676             pv++;
2677     }
2678
2679     return SvPVX(dsv);
2680 }
2681
2682 char *
2683 Perl_sv_xmlpeek(pTHX_ SV *sv)
2684 {
2685     SV * const t = sv_newmortal();
2686     STRLEN n_a;
2687     int unref = 0;
2688
2689     PERL_ARGS_ASSERT_SV_XMLPEEK;
2690
2691     sv_utf8_upgrade(t);
2692     sv_setpvs(t, "");
2693     /* retry: */
2694     if (!sv) {
2695         sv_catpv(t, "VOID=\"\"");
2696         goto finish;
2697     }
2698     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2699         sv_catpv(t, "WILD=\"\"");
2700         goto finish;
2701     }
2702     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2703         if (sv == &PL_sv_undef) {
2704             sv_catpv(t, "SV_UNDEF=\"1\"");
2705             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2706                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2707                 SvREADONLY(sv))
2708                 goto finish;
2709         }
2710         else if (sv == &PL_sv_no) {
2711             sv_catpv(t, "SV_NO=\"1\"");
2712             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2713                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2714                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2715                                   SVp_POK|SVp_NOK)) &&
2716                 SvCUR(sv) == 0 &&
2717                 SvNVX(sv) == 0.0)
2718                 goto finish;
2719         }
2720         else if (sv == &PL_sv_yes) {
2721             sv_catpv(t, "SV_YES=\"1\"");
2722             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2723                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2724                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2725                                   SVp_POK|SVp_NOK)) &&
2726                 SvCUR(sv) == 1 &&
2727                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2728                 SvNVX(sv) == 1.0)
2729                 goto finish;
2730         }
2731         else {
2732             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2733             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2734                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2735                 SvREADONLY(sv))
2736                 goto finish;
2737         }
2738         sv_catpv(t, " XXX=\"\" ");
2739     }
2740     else if (SvREFCNT(sv) == 0) {
2741         sv_catpv(t, " refcnt=\"0\"");
2742         unref++;
2743     }
2744     else if (DEBUG_R_TEST_) {
2745         int is_tmp = 0;
2746         I32 ix;
2747         /* is this SV on the tmps stack? */
2748         for (ix=PL_tmps_ix; ix>=0; ix--) {
2749             if (PL_tmps_stack[ix] == sv) {
2750                 is_tmp = 1;
2751                 break;
2752             }
2753         }
2754         if (SvREFCNT(sv) > 1)
2755             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2756                     is_tmp ? "T" : "");
2757         else if (is_tmp)
2758             sv_catpv(t, " DRT=\"<T>\"");
2759     }
2760
2761     if (SvROK(sv)) {
2762         sv_catpv(t, " ROK=\"\"");
2763     }
2764     switch (SvTYPE(sv)) {
2765     default:
2766         sv_catpv(t, " FREED=\"1\"");
2767         goto finish;
2768
2769     case SVt_NULL:
2770         sv_catpv(t, " UNDEF=\"1\"");
2771         goto finish;
2772     case SVt_IV:
2773         sv_catpv(t, " IV=\"");
2774         break;
2775     case SVt_NV:
2776         sv_catpv(t, " NV=\"");
2777         break;
2778     case SVt_PV:
2779         sv_catpv(t, " PV=\"");
2780         break;
2781     case SVt_PVIV:
2782         sv_catpv(t, " PVIV=\"");
2783         break;
2784     case SVt_PVNV:
2785         sv_catpv(t, " PVNV=\"");
2786         break;
2787     case SVt_PVMG:
2788         sv_catpv(t, " PVMG=\"");
2789         break;
2790     case SVt_PVLV:
2791         sv_catpv(t, " PVLV=\"");
2792         break;
2793     case SVt_PVAV:
2794         sv_catpv(t, " AV=\"");
2795         break;
2796     case SVt_PVHV:
2797         sv_catpv(t, " HV=\"");
2798         break;
2799     case SVt_PVCV:
2800         if (CvGV(sv))
2801             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2802         else
2803             sv_catpv(t, " CV=\"()\"");
2804         goto finish;
2805     case SVt_PVGV:
2806         sv_catpv(t, " GV=\"");
2807         break;
2808     case SVt_BIND:
2809         sv_catpv(t, " BIND=\"");
2810         break;
2811     case SVt_REGEXP:
2812         sv_catpv(t, " REGEXP=\"");
2813         break;
2814     case SVt_PVFM:
2815         sv_catpv(t, " FM=\"");
2816         break;
2817     case SVt_PVIO:
2818         sv_catpv(t, " IO=\"");
2819         break;
2820     }
2821
2822     if (SvPOKp(sv)) {
2823         if (SvPVX(sv)) {
2824             sv_catxmlsv(t, sv);
2825         }
2826     }
2827     else if (SvNOKp(sv)) {
2828         STORE_NUMERIC_LOCAL_SET_STANDARD();
2829         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2830         RESTORE_NUMERIC_LOCAL();
2831     }
2832     else if (SvIOKp(sv)) {
2833         if (SvIsUV(sv))
2834             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2835         else
2836             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2837     }
2838     else
2839         sv_catpv(t, "");
2840     sv_catpv(t, "\"");
2841
2842   finish:
2843     while (unref--)
2844         sv_catpv(t, ")");
2845     return SvPV(t, n_a);
2846 }
2847
2848 void
2849 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2850 {
2851     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2852
2853     if (!pm) {
2854         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2855         return;
2856     }
2857     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2858     level++;
2859     if (PM_GETRE(pm)) {
2860         REGEXP *const r = PM_GETRE(pm);
2861         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2862         sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2863         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2864              SvPVX(tmpsv));
2865         SvREFCNT_dec(tmpsv);
2866         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2867              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2868     }
2869     else
2870         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2871     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2872         SV * const tmpsv = pm_description(pm);
2873         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2874         SvREFCNT_dec(tmpsv);
2875     }
2876
2877     level--;
2878     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2879         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2880         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2881         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2882         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2883         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2884     }
2885     else
2886         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2887 }
2888
2889 void
2890 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2891 {
2892     do_pmop_xmldump(0, PL_xmlfp, pm);
2893 }
2894
2895 void
2896 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2897 {
2898     UV      seq;
2899     int     contents = 0;
2900
2901     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2902
2903     if (!o)
2904         return;
2905     sequence(o);
2906     seq = sequence_num(o);
2907     Perl_xmldump_indent(aTHX_ level, file,
2908         "<op_%s seq=\"%"UVuf" -> ",
2909              OP_NAME(o),
2910                       seq);
2911     level++;
2912     if (o->op_next)
2913         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2914                       sequence_num(o->op_next));
2915     else
2916         PerlIO_printf(file, "DONE\"");
2917
2918     if (o->op_targ) {
2919         if (o->op_type == OP_NULL)
2920         {
2921             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2922             if (o->op_targ == OP_NEXTSTATE)
2923             {
2924                 if (CopLINE(cCOPo))
2925                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2926                                      (UV)CopLINE(cCOPo));
2927                 if (CopSTASHPV(cCOPo))
2928                     PerlIO_printf(file, " package=\"%s\"",
2929                                      CopSTASHPV(cCOPo));
2930                 if (CopLABEL(cCOPo))
2931                     PerlIO_printf(file, " label=\"%s\"",
2932                                      CopLABEL(cCOPo));
2933             }
2934         }
2935         else
2936             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2937     }
2938 #ifdef DUMPADDR
2939     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2940 #endif
2941     if (o->op_flags) {
2942         SV * const tmpsv = newSVpvs("");
2943         switch (o->op_flags & OPf_WANT) {
2944         case OPf_WANT_VOID:
2945             sv_catpv(tmpsv, ",VOID");
2946             break;
2947         case OPf_WANT_SCALAR:
2948             sv_catpv(tmpsv, ",SCALAR");
2949             break;
2950         case OPf_WANT_LIST:
2951             sv_catpv(tmpsv, ",LIST");
2952             break;
2953         default:
2954             sv_catpv(tmpsv, ",UNKNOWN");
2955             break;
2956         }
2957         if (o->op_flags & OPf_KIDS)
2958             sv_catpv(tmpsv, ",KIDS");
2959         if (o->op_flags & OPf_PARENS)
2960             sv_catpv(tmpsv, ",PARENS");
2961         if (o->op_flags & OPf_STACKED)
2962             sv_catpv(tmpsv, ",STACKED");
2963         if (o->op_flags & OPf_REF)
2964             sv_catpv(tmpsv, ",REF");
2965         if (o->op_flags & OPf_MOD)
2966             sv_catpv(tmpsv, ",MOD");
2967         if (o->op_flags & OPf_SPECIAL)
2968             sv_catpv(tmpsv, ",SPECIAL");
2969         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2970         SvREFCNT_dec(tmpsv);
2971     }
2972     if (o->op_private) {
2973         SV * const tmpsv = newSVpvs("");
2974         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2975             if (o->op_private & OPpTARGET_MY)
2976                 sv_catpv(tmpsv, ",TARGET_MY");
2977         }
2978         else if (o->op_type == OP_LEAVESUB ||
2979                  o->op_type == OP_LEAVE ||
2980                  o->op_type == OP_LEAVESUBLV ||
2981                  o->op_type == OP_LEAVEWRITE) {
2982             if (o->op_private & OPpREFCOUNTED)
2983                 sv_catpv(tmpsv, ",REFCOUNTED");
2984         }
2985         else if (o->op_type == OP_AASSIGN) {
2986             if (o->op_private & OPpASSIGN_COMMON)
2987                 sv_catpv(tmpsv, ",COMMON");
2988         }
2989         else if (o->op_type == OP_SASSIGN) {
2990             if (o->op_private & OPpASSIGN_BACKWARDS)
2991                 sv_catpv(tmpsv, ",BACKWARDS");
2992         }
2993         else if (o->op_type == OP_TRANS) {
2994             if (o->op_private & OPpTRANS_SQUASH)
2995                 sv_catpv(tmpsv, ",SQUASH");
2996             if (o->op_private & OPpTRANS_DELETE)
2997                 sv_catpv(tmpsv, ",DELETE");
2998             if (o->op_private & OPpTRANS_COMPLEMENT)
2999                 sv_catpv(tmpsv, ",COMPLEMENT");
3000             if (o->op_private & OPpTRANS_IDENTICAL)
3001                 sv_catpv(tmpsv, ",IDENTICAL");
3002             if (o->op_private & OPpTRANS_GROWS)
3003                 sv_catpv(tmpsv, ",GROWS");
3004         }
3005         else if (o->op_type == OP_REPEAT) {
3006             if (o->op_private & OPpREPEAT_DOLIST)
3007                 sv_catpv(tmpsv, ",DOLIST");
3008         }
3009         else if (o->op_type == OP_ENTERSUB ||
3010                  o->op_type == OP_RV2SV ||
3011                  o->op_type == OP_GVSV ||
3012                  o->op_type == OP_RV2AV ||
3013                  o->op_type == OP_RV2HV ||
3014                  o->op_type == OP_RV2GV ||
3015                  o->op_type == OP_AELEM ||
3016                  o->op_type == OP_HELEM )
3017         {
3018             if (o->op_type == OP_ENTERSUB) {
3019                 if (o->op_private & OPpENTERSUB_AMPER)
3020                     sv_catpv(tmpsv, ",AMPER");
3021                 if (o->op_private & OPpENTERSUB_DB)
3022                     sv_catpv(tmpsv, ",DB");
3023                 if (o->op_private & OPpENTERSUB_HASTARG)
3024                     sv_catpv(tmpsv, ",HASTARG");
3025                 if (o->op_private & OPpENTERSUB_NOPAREN)
3026                     sv_catpv(tmpsv, ",NOPAREN");
3027                 if (o->op_private & OPpENTERSUB_INARGS)
3028                     sv_catpv(tmpsv, ",INARGS");
3029                 if (o->op_private & OPpENTERSUB_NOMOD)
3030                     sv_catpv(tmpsv, ",NOMOD");
3031             }
3032             else {
3033                 switch (o->op_private & OPpDEREF) {
3034             case OPpDEREF_SV:
3035                 sv_catpv(tmpsv, ",SV");
3036                 break;
3037             case OPpDEREF_AV:
3038                 sv_catpv(tmpsv, ",AV");
3039                 break;
3040             case OPpDEREF_HV:
3041                 sv_catpv(tmpsv, ",HV");
3042                 break;
3043             }
3044                 if (o->op_private & OPpMAYBE_LVSUB)
3045                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
3046             }
3047             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
3048                 if (o->op_private & OPpLVAL_DEFER)
3049                     sv_catpv(tmpsv, ",LVAL_DEFER");
3050             }
3051             else {
3052                 if (o->op_private & HINT_STRICT_REFS)
3053                     sv_catpv(tmpsv, ",STRICT_REFS");
3054                 if (o->op_private & OPpOUR_INTRO)
3055                     sv_catpv(tmpsv, ",OUR_INTRO");
3056             }
3057         }
3058         else if (o->op_type == OP_CONST) {
3059             if (o->op_private & OPpCONST_BARE)
3060                 sv_catpv(tmpsv, ",BARE");
3061             if (o->op_private & OPpCONST_STRICT)
3062                 sv_catpv(tmpsv, ",STRICT");
3063             if (o->op_private & OPpCONST_ARYBASE)
3064                 sv_catpv(tmpsv, ",ARYBASE");
3065             if (o->op_private & OPpCONST_WARNING)
3066                 sv_catpv(tmpsv, ",WARNING");
3067             if (o->op_private & OPpCONST_ENTERED)
3068                 sv_catpv(tmpsv, ",ENTERED");
3069         }
3070         else if (o->op_type == OP_FLIP) {
3071             if (o->op_private & OPpFLIP_LINENUM)
3072                 sv_catpv(tmpsv, ",LINENUM");
3073         }
3074         else if (o->op_type == OP_FLOP) {
3075             if (o->op_private & OPpFLIP_LINENUM)
3076                 sv_catpv(tmpsv, ",LINENUM");
3077         }
3078         else if (o->op_type == OP_RV2CV) {
3079             if (o->op_private & OPpLVAL_INTRO)
3080                 sv_catpv(tmpsv, ",INTRO");
3081         }
3082         else if (o->op_type == OP_GV) {
3083             if (o->op_private & OPpEARLY_CV)
3084                 sv_catpv(tmpsv, ",EARLY_CV");
3085         }
3086         else if (o->op_type == OP_LIST) {
3087             if (o->op_private & OPpLIST_GUESSED)
3088                 sv_catpv(tmpsv, ",GUESSED");
3089         }
3090         else if (o->op_type == OP_DELETE) {
3091             if (o->op_private & OPpSLICE)
3092                 sv_catpv(tmpsv, ",SLICE");
3093         }
3094         else if (o->op_type == OP_EXISTS) {
3095             if (o->op_private & OPpEXISTS_SUB)
3096                 sv_catpv(tmpsv, ",EXISTS_SUB");
3097         }
3098         else if (o->op_type == OP_SORT) {
3099             if (o->op_private & OPpSORT_NUMERIC)
3100                 sv_catpv(tmpsv, ",NUMERIC");
3101             if (o->op_private & OPpSORT_INTEGER)
3102                 sv_catpv(tmpsv, ",INTEGER");
3103             if (o->op_private & OPpSORT_REVERSE)
3104                 sv_catpv(tmpsv, ",REVERSE");
3105         }
3106         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
3107             if (o->op_private & OPpOPEN_IN_RAW)
3108                 sv_catpv(tmpsv, ",IN_RAW");
3109             if (o->op_private & OPpOPEN_IN_CRLF)
3110                 sv_catpv(tmpsv, ",IN_CRLF");
3111             if (o->op_private & OPpOPEN_OUT_RAW)
3112                 sv_catpv(tmpsv, ",OUT_RAW");
3113             if (o->op_private & OPpOPEN_OUT_CRLF)
3114                 sv_catpv(tmpsv, ",OUT_CRLF");
3115         }
3116         else if (o->op_type == OP_EXIT) {
3117             if (o->op_private & OPpEXIT_VMSISH)
3118                 sv_catpv(tmpsv, ",EXIT_VMSISH");
3119             if (o->op_private & OPpHUSH_VMSISH)
3120                 sv_catpv(tmpsv, ",HUSH_VMSISH");
3121         }
3122         else if (o->op_type == OP_DIE) {
3123             if (o->op_private & OPpHUSH_VMSISH)
3124                 sv_catpv(tmpsv, ",HUSH_VMSISH");
3125         }
3126         else if (PL_check[o->op_type] != Perl_ck_ftst) {
3127             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
3128                 sv_catpv(tmpsv, ",FT_ACCESS");
3129             if (o->op_private & OPpFT_STACKED)
3130                 sv_catpv(tmpsv, ",FT_STACKED");
3131         }
3132         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
3133             sv_catpv(tmpsv, ",INTRO");
3134         if (SvCUR(tmpsv))
3135             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
3136         SvREFCNT_dec(tmpsv);
3137     }
3138
3139     switch (o->op_type) {
3140     case OP_AELEMFAST:
3141         if (o->op_flags & OPf_SPECIAL) {
3142             break;
3143         }
3144     case OP_GVSV:
3145     case OP_GV:
3146 #ifdef USE_ITHREADS
3147         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3148 #else
3149         if (cSVOPo->op_sv) {
3150             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3151             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3152             char *s;
3153             STRLEN len;
3154             ENTER;
3155             SAVEFREESV(tmpsv1);
3156             SAVEFREESV(tmpsv2);
3157             gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3158             s = SvPV(tmpsv1,len);
3159             sv_catxmlpvn(tmpsv2, s, len, 1);
3160             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3161             LEAVE;
3162         }
3163         else
3164             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3165 #endif
3166         break;
3167     case OP_CONST:
3168     case OP_HINTSEVAL:
3169     case OP_METHOD_NAMED:
3170 #ifndef USE_ITHREADS
3171         /* with ITHREADS, consts are stored in the pad, and the right pad
3172          * may not be active here, so skip */
3173         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3174 #endif
3175         break;
3176     case OP_ANONCODE:
3177         if (!contents) {
3178             contents = 1;
3179             PerlIO_printf(file, ">\n");
3180         }
3181         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3182         break;
3183     case OP_NEXTSTATE:
3184     case OP_DBSTATE:
3185         if (CopLINE(cCOPo))
3186             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3187                              (UV)CopLINE(cCOPo));
3188         if (CopSTASHPV(cCOPo))
3189             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3190                              CopSTASHPV(cCOPo));
3191         if (CopLABEL(cCOPo))
3192             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3193                              CopLABEL(cCOPo));
3194         break;
3195     case OP_ENTERLOOP:
3196         S_xmldump_attr(aTHX_ level, file, "redo=\"");
3197         if (cLOOPo->op_redoop)
3198             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3199         else
3200             PerlIO_printf(file, "DONE\"");
3201         S_xmldump_attr(aTHX_ level, file, "next=\"");
3202         if (cLOOPo->op_nextop)
3203             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3204         else
3205             PerlIO_printf(file, "DONE\"");
3206         S_xmldump_attr(aTHX_ level, file, "last=\"");
3207         if (cLOOPo->op_lastop)
3208             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3209         else
3210             PerlIO_printf(file, "DONE\"");
3211         break;
3212     case OP_COND_EXPR:
3213     case OP_RANGE:
3214     case OP_MAPWHILE:
3215     case OP_GREPWHILE:
3216     case OP_OR:
3217     case OP_AND:
3218         S_xmldump_attr(aTHX_ level, file, "other=\"");
3219         if (cLOGOPo->op_other)
3220             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3221         else
3222             PerlIO_printf(file, "DONE\"");
3223         break;
3224     case OP_LEAVE:
3225     case OP_LEAVEEVAL:
3226     case OP_LEAVESUB:
3227     case OP_LEAVESUBLV:
3228     case OP_LEAVEWRITE:
3229     case OP_SCOPE:
3230         if (o->op_private & OPpREFCOUNTED)
3231             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3232         break;
3233     default:
3234         break;
3235     }
3236
3237     if (PL_madskills && o->op_madprop) {
3238         char prevkey = '\0';
3239         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3240         const MADPROP* mp = o->op_madprop;
3241
3242         if (!contents) {
3243             contents = 1;
3244             PerlIO_printf(file, ">\n");
3245         }
3246         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3247         level++;
3248         while (mp) {
3249             char tmp = mp->mad_key;
3250             sv_setpvs(tmpsv,"\"");
3251             if (tmp)
3252                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3253             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3254                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3255             else
3256                 prevkey = tmp;
3257             sv_catpv(tmpsv, "\"");
3258             switch (mp->mad_type) {
3259             case MAD_NULL:
3260                 sv_catpv(tmpsv, "NULL");
3261                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3262                 break;
3263             case MAD_PV:
3264                 sv_catpv(tmpsv, " val=\"");
3265                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3266                 sv_catpv(tmpsv, "\"");
3267                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3268                 break;
3269             case MAD_SV:
3270                 sv_catpv(tmpsv, " val=\"");
3271                 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3272                 sv_catpv(tmpsv, "\"");
3273                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3274                 break;
3275             case MAD_OP:
3276                 if ((OP*)mp->mad_val) {
3277                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3278                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3279                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3280                 }
3281                 break;
3282             default:
3283                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3284                 break;
3285             }
3286             mp = mp->mad_next;
3287         }
3288         level--;
3289         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3290
3291         SvREFCNT_dec(tmpsv);
3292     }
3293
3294     switch (o->op_type) {
3295     case OP_PUSHRE:
3296     case OP_MATCH:
3297     case OP_QR:
3298     case OP_SUBST:
3299         if (!contents) {
3300             contents = 1;
3301             PerlIO_printf(file, ">\n");
3302         }
3303         do_pmop_xmldump(level, file, cPMOPo);
3304         break;
3305     default:
3306         break;
3307     }
3308
3309     if (o->op_flags & OPf_KIDS) {
3310         OP *kid;
3311         if (!contents) {
3312             contents = 1;
3313             PerlIO_printf(file, ">\n");
3314         }
3315         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3316             do_op_xmldump(level, file, kid);
3317     }
3318
3319     if (contents)
3320         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3321     else
3322         PerlIO_printf(file, " />\n");
3323 }
3324
3325 void
3326 Perl_op_xmldump(pTHX_ const OP *o)
3327 {
3328     PERL_ARGS_ASSERT_OP_XMLDUMP;
3329
3330     do_op_xmldump(0, PL_xmlfp, o);
3331 }
3332 #endif
3333
3334 /*
3335  * Local variables:
3336  * c-indentation-style: bsd
3337  * c-basic-offset: 4
3338  * indent-tabs-mode: t
3339  * End:
3340  *
3341  * ex: set ts=8 sts=4 sw=4 noet:
3342  */