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