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     xmldump_packsubs_perl(stash, FALSE);
2235 }
2236
2237 void
2238 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2239 {
2240     I32 i;
2241     HE  *entry;
2242
2243     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2244
2245     if (!HvARRAY(stash))
2246         return;
2247     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2248         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2249             GV *gv = MUTABLE_GV(HeVAL(entry));
2250             HV *hv;
2251             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2252                 continue;
2253             if (GvCVu(gv))
2254                 xmldump_sub_perl(gv, justperl);
2255             if (GvFORM(gv))
2256                 xmldump_form(gv);
2257             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2258                 && (hv = GvHV(gv)) && hv != PL_defstash)
2259                 xmldump_packsubs_perl(hv, justperl);    /* nested package */
2260         }
2261     }
2262 }
2263
2264 void
2265 Perl_xmldump_sub(pTHX_ const GV *gv)
2266 {
2267     xmldump_sub_perl(gv, FALSE);
2268 }
2269
2270 void
2271 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2272 {
2273     SV * sv;
2274
2275     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2276
2277     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2278         return;
2279
2280     sv = sv_newmortal();
2281     gv_fullname3(sv, gv, NULL);
2282     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2283     if (CvXSUB(GvCV(gv)))
2284         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2285             PTR2UV(CvXSUB(GvCV(gv))),
2286             (int)CvXSUBANY(GvCV(gv)).any_i32);
2287     else if (CvROOT(GvCV(gv)))
2288         op_xmldump(CvROOT(GvCV(gv)));
2289     else
2290         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2291 }
2292
2293 void
2294 Perl_xmldump_form(pTHX_ const GV *gv)
2295 {
2296     SV * const sv = sv_newmortal();
2297
2298     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2299
2300     gv_fullname3(sv, gv, NULL);
2301     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2302     if (CvROOT(GvFORM(gv)))
2303         op_xmldump(CvROOT(GvFORM(gv)));
2304     else
2305         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2306 }
2307
2308 void
2309 Perl_xmldump_eval(pTHX)
2310 {
2311     op_xmldump(PL_eval_root);
2312 }
2313
2314 char *
2315 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2316 {
2317     PERL_ARGS_ASSERT_SV_CATXMLSV;
2318     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2319 }
2320
2321 char *
2322 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2323 {
2324     unsigned int c;
2325     const char * const e = pv + len;
2326     const char * const start = pv;
2327     STRLEN dsvcur;
2328     STRLEN cl;
2329
2330     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2331
2332     sv_catpvs(dsv,"");
2333     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2334
2335   retry:
2336     while (pv < e) {
2337         if (utf8) {
2338             c = utf8_to_uvchr((U8*)pv, &cl);
2339             if (cl == 0) {
2340                 SvCUR(dsv) = dsvcur;
2341                 pv = start;
2342                 utf8 = 0;
2343                 goto retry;
2344             }
2345         }
2346         else
2347             c = (*pv & 255);
2348
2349         switch (c) {
2350         case 0x00:
2351         case 0x01:
2352         case 0x02:
2353         case 0x03:
2354         case 0x04:
2355         case 0x05:
2356         case 0x06:
2357         case 0x07:
2358         case 0x08:
2359         case 0x0b:
2360         case 0x0c:
2361         case 0x0e:
2362         case 0x0f:
2363         case 0x10:
2364         case 0x11:
2365         case 0x12:
2366         case 0x13:
2367         case 0x14:
2368         case 0x15:
2369         case 0x16:
2370         case 0x17:
2371         case 0x18:
2372         case 0x19:
2373         case 0x1a:
2374         case 0x1b:
2375         case 0x1c:
2376         case 0x1d:
2377         case 0x1e:
2378         case 0x1f:
2379         case 0x7f:
2380         case 0x80:
2381         case 0x81:
2382         case 0x82:
2383         case 0x83:
2384         case 0x84:
2385         case 0x86:
2386         case 0x87:
2387         case 0x88:
2388         case 0x89:
2389         case 0x90:
2390         case 0x91:
2391         case 0x92:
2392         case 0x93:
2393         case 0x94:
2394         case 0x95:
2395         case 0x96:
2396         case 0x97:
2397         case 0x98:
2398         case 0x99:
2399         case 0x9a:
2400         case 0x9b:
2401         case 0x9c:
2402         case 0x9d:
2403         case 0x9e:
2404         case 0x9f:
2405             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2406             break;
2407         case '<':
2408             sv_catpvs(dsv, "&lt;");
2409             break;
2410         case '>':
2411             sv_catpvs(dsv, "&gt;");
2412             break;
2413         case '&':
2414             sv_catpvs(dsv, "&amp;");
2415             break;
2416         case '"':
2417             sv_catpvs(dsv, "&#34;");
2418             break;
2419         default:
2420             if (c < 0xD800) {
2421                 if (c < 32 || c > 127) {
2422                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2423                 }
2424                 else {
2425                     const char string = (char) c;
2426                     sv_catpvn(dsv, &string, 1);
2427                 }
2428                 break;
2429             }
2430             if ((c >= 0xD800 && c <= 0xDB7F) ||
2431                 (c >= 0xDC00 && c <= 0xDFFF) ||
2432                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2433                  c > 0x10ffff)
2434                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2435             else
2436                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2437         }
2438
2439         if (utf8)
2440             pv += UTF8SKIP(pv);
2441         else
2442             pv++;
2443     }
2444
2445     return SvPVX(dsv);
2446 }
2447
2448 char *
2449 Perl_sv_xmlpeek(pTHX_ SV *sv)
2450 {
2451     SV * const t = sv_newmortal();
2452     STRLEN n_a;
2453     int unref = 0;
2454
2455     PERL_ARGS_ASSERT_SV_XMLPEEK;
2456
2457     sv_utf8_upgrade(t);
2458     sv_setpvs(t, "");
2459     /* retry: */
2460     if (!sv) {
2461         sv_catpv(t, "VOID=\"\"");
2462         goto finish;
2463     }
2464     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2465         sv_catpv(t, "WILD=\"\"");
2466         goto finish;
2467     }
2468     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2469         if (sv == &PL_sv_undef) {
2470             sv_catpv(t, "SV_UNDEF=\"1\"");
2471             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2472                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2473                 SvREADONLY(sv))
2474                 goto finish;
2475         }
2476         else if (sv == &PL_sv_no) {
2477             sv_catpv(t, "SV_NO=\"1\"");
2478             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2479                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2480                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2481                                   SVp_POK|SVp_NOK)) &&
2482                 SvCUR(sv) == 0 &&
2483                 SvNVX(sv) == 0.0)
2484                 goto finish;
2485         }
2486         else if (sv == &PL_sv_yes) {
2487             sv_catpv(t, "SV_YES=\"1\"");
2488             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2489                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2490                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2491                                   SVp_POK|SVp_NOK)) &&
2492                 SvCUR(sv) == 1 &&
2493                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2494                 SvNVX(sv) == 1.0)
2495                 goto finish;
2496         }
2497         else {
2498             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2499             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2500                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2501                 SvREADONLY(sv))
2502                 goto finish;
2503         }
2504         sv_catpv(t, " XXX=\"\" ");
2505     }
2506     else if (SvREFCNT(sv) == 0) {
2507         sv_catpv(t, " refcnt=\"0\"");
2508         unref++;
2509     }
2510     else if (DEBUG_R_TEST_) {
2511         int is_tmp = 0;
2512         I32 ix;
2513         /* is this SV on the tmps stack? */
2514         for (ix=PL_tmps_ix; ix>=0; ix--) {
2515             if (PL_tmps_stack[ix] == sv) {
2516                 is_tmp = 1;
2517                 break;
2518             }
2519         }
2520         if (SvREFCNT(sv) > 1)
2521             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2522                     is_tmp ? "T" : "");
2523         else if (is_tmp)
2524             sv_catpv(t, " DRT=\"<T>\"");
2525     }
2526
2527     if (SvROK(sv)) {
2528         sv_catpv(t, " ROK=\"\"");
2529     }
2530     switch (SvTYPE(sv)) {
2531     default:
2532         sv_catpv(t, " FREED=\"1\"");
2533         goto finish;
2534
2535     case SVt_NULL:
2536         sv_catpv(t, " UNDEF=\"1\"");
2537         goto finish;
2538     case SVt_IV:
2539         sv_catpv(t, " IV=\"");
2540         break;
2541     case SVt_NV:
2542         sv_catpv(t, " NV=\"");
2543         break;
2544     case SVt_PV:
2545         sv_catpv(t, " PV=\"");
2546         break;
2547     case SVt_PVIV:
2548         sv_catpv(t, " PVIV=\"");
2549         break;
2550     case SVt_PVNV:
2551         sv_catpv(t, " PVNV=\"");
2552         break;
2553     case SVt_PVMG:
2554         sv_catpv(t, " PVMG=\"");
2555         break;
2556     case SVt_PVLV:
2557         sv_catpv(t, " PVLV=\"");
2558         break;
2559     case SVt_PVAV:
2560         sv_catpv(t, " AV=\"");
2561         break;
2562     case SVt_PVHV:
2563         sv_catpv(t, " HV=\"");
2564         break;
2565     case SVt_PVCV:
2566         if (CvGV(sv))
2567             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2568         else
2569             sv_catpv(t, " CV=\"()\"");
2570         goto finish;
2571     case SVt_PVGV:
2572         sv_catpv(t, " GV=\"");
2573         break;
2574     case SVt_BIND:
2575         sv_catpv(t, " BIND=\"");
2576         break;
2577     case SVt_REGEXP:
2578         sv_catpv(t, " ORANGE=\"");
2579         break;
2580     case SVt_PVFM:
2581         sv_catpv(t, " FM=\"");
2582         break;
2583     case SVt_PVIO:
2584         sv_catpv(t, " IO=\"");
2585         break;
2586     }
2587
2588     if (SvPOKp(sv)) {
2589         if (SvPVX(sv)) {
2590             sv_catxmlsv(t, sv);
2591         }
2592     }
2593     else if (SvNOKp(sv)) {
2594         STORE_NUMERIC_LOCAL_SET_STANDARD();
2595         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2596         RESTORE_NUMERIC_LOCAL();
2597     }
2598     else if (SvIOKp(sv)) {
2599         if (SvIsUV(sv))
2600             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2601         else
2602             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2603     }
2604     else
2605         sv_catpv(t, "");
2606     sv_catpv(t, "\"");
2607
2608   finish:
2609     while (unref--)
2610         sv_catpv(t, ")");
2611     return SvPV(t, n_a);
2612 }
2613
2614 void
2615 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2616 {
2617     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2618
2619     if (!pm) {
2620         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2621         return;
2622     }
2623     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2624     level++;
2625     if (PM_GETRE(pm)) {
2626         REGEXP *const r = PM_GETRE(pm);
2627         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2628         sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2629         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2630              SvPVX(tmpsv));
2631         SvREFCNT_dec(tmpsv);
2632         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2633              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2634     }
2635     else
2636         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2637     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2638         SV * const tmpsv = pm_description(pm);
2639         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2640         SvREFCNT_dec(tmpsv);
2641     }
2642
2643     level--;
2644     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2645         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2646         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2647         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2648         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2649         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2650     }
2651     else
2652         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2653 }
2654
2655 void
2656 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2657 {
2658     do_pmop_xmldump(0, PL_xmlfp, pm);
2659 }
2660
2661 void
2662 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2663 {
2664     UV      seq;
2665     int     contents = 0;
2666
2667     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2668
2669     if (!o)
2670         return;
2671     sequence(o);
2672     seq = sequence_num(o);
2673     Perl_xmldump_indent(aTHX_ level, file,
2674         "<op_%s seq=\"%"UVuf" -> ",
2675              OP_NAME(o),
2676                       seq);
2677     level++;
2678     if (o->op_next)
2679         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2680                       sequence_num(o->op_next));
2681     else
2682         PerlIO_printf(file, "DONE\"");
2683
2684     if (o->op_targ) {
2685         if (o->op_type == OP_NULL)
2686         {
2687             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2688             if (o->op_targ == OP_NEXTSTATE)
2689             {
2690                 if (CopLINE(cCOPo))
2691                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2692                                      (UV)CopLINE(cCOPo));
2693                 if (CopSTASHPV(cCOPo))
2694                     PerlIO_printf(file, " package=\"%s\"",
2695                                      CopSTASHPV(cCOPo));
2696                 if (CopLABEL(cCOPo))
2697                     PerlIO_printf(file, " label=\"%s\"",
2698                                      CopLABEL(cCOPo));
2699             }
2700         }
2701         else
2702             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2703     }
2704 #ifdef DUMPADDR
2705     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2706 #endif
2707     if (o->op_flags) {
2708         SV * const tmpsv = newSVpvs("");
2709         switch (o->op_flags & OPf_WANT) {
2710         case OPf_WANT_VOID:
2711             sv_catpv(tmpsv, ",VOID");
2712             break;
2713         case OPf_WANT_SCALAR:
2714             sv_catpv(tmpsv, ",SCALAR");
2715             break;
2716         case OPf_WANT_LIST:
2717             sv_catpv(tmpsv, ",LIST");
2718             break;
2719         default:
2720             sv_catpv(tmpsv, ",UNKNOWN");
2721             break;
2722         }
2723         if (o->op_flags & OPf_KIDS)
2724             sv_catpv(tmpsv, ",KIDS");
2725         if (o->op_flags & OPf_PARENS)
2726             sv_catpv(tmpsv, ",PARENS");
2727         if (o->op_flags & OPf_STACKED)
2728             sv_catpv(tmpsv, ",STACKED");
2729         if (o->op_flags & OPf_REF)
2730             sv_catpv(tmpsv, ",REF");
2731         if (o->op_flags & OPf_MOD)
2732             sv_catpv(tmpsv, ",MOD");
2733         if (o->op_flags & OPf_SPECIAL)
2734             sv_catpv(tmpsv, ",SPECIAL");
2735         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2736         SvREFCNT_dec(tmpsv);
2737     }
2738     if (o->op_private) {
2739         SV * const tmpsv = newSVpvs("");
2740         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2741             if (o->op_private & OPpTARGET_MY)
2742                 sv_catpv(tmpsv, ",TARGET_MY");
2743         }
2744         else if (o->op_type == OP_LEAVESUB ||
2745                  o->op_type == OP_LEAVE ||
2746                  o->op_type == OP_LEAVESUBLV ||
2747                  o->op_type == OP_LEAVEWRITE) {
2748             if (o->op_private & OPpREFCOUNTED)
2749                 sv_catpv(tmpsv, ",REFCOUNTED");
2750         }
2751         else if (o->op_type == OP_AASSIGN) {
2752             if (o->op_private & OPpASSIGN_COMMON)
2753                 sv_catpv(tmpsv, ",COMMON");
2754         }
2755         else if (o->op_type == OP_SASSIGN) {
2756             if (o->op_private & OPpASSIGN_BACKWARDS)
2757                 sv_catpv(tmpsv, ",BACKWARDS");
2758         }
2759         else if (o->op_type == OP_TRANS) {
2760             if (o->op_private & OPpTRANS_SQUASH)
2761                 sv_catpv(tmpsv, ",SQUASH");
2762             if (o->op_private & OPpTRANS_DELETE)
2763                 sv_catpv(tmpsv, ",DELETE");
2764             if (o->op_private & OPpTRANS_COMPLEMENT)
2765                 sv_catpv(tmpsv, ",COMPLEMENT");
2766             if (o->op_private & OPpTRANS_IDENTICAL)
2767                 sv_catpv(tmpsv, ",IDENTICAL");
2768             if (o->op_private & OPpTRANS_GROWS)
2769                 sv_catpv(tmpsv, ",GROWS");
2770         }
2771         else if (o->op_type == OP_REPEAT) {
2772             if (o->op_private & OPpREPEAT_DOLIST)
2773                 sv_catpv(tmpsv, ",DOLIST");
2774         }
2775         else if (o->op_type == OP_ENTERSUB ||
2776                  o->op_type == OP_RV2SV ||
2777                  o->op_type == OP_GVSV ||
2778                  o->op_type == OP_RV2AV ||
2779                  o->op_type == OP_RV2HV ||
2780                  o->op_type == OP_RV2GV ||
2781                  o->op_type == OP_AELEM ||
2782                  o->op_type == OP_HELEM )
2783         {
2784             if (o->op_type == OP_ENTERSUB) {
2785                 if (o->op_private & OPpENTERSUB_AMPER)
2786                     sv_catpv(tmpsv, ",AMPER");
2787                 if (o->op_private & OPpENTERSUB_DB)
2788                     sv_catpv(tmpsv, ",DB");
2789                 if (o->op_private & OPpENTERSUB_HASTARG)
2790                     sv_catpv(tmpsv, ",HASTARG");
2791                 if (o->op_private & OPpENTERSUB_NOPAREN)
2792                     sv_catpv(tmpsv, ",NOPAREN");
2793                 if (o->op_private & OPpENTERSUB_INARGS)
2794                     sv_catpv(tmpsv, ",INARGS");
2795                 if (o->op_private & OPpENTERSUB_NOMOD)
2796                     sv_catpv(tmpsv, ",NOMOD");
2797             }
2798             else {
2799                 switch (o->op_private & OPpDEREF) {
2800             case OPpDEREF_SV:
2801                 sv_catpv(tmpsv, ",SV");
2802                 break;
2803             case OPpDEREF_AV:
2804                 sv_catpv(tmpsv, ",AV");
2805                 break;
2806             case OPpDEREF_HV:
2807                 sv_catpv(tmpsv, ",HV");
2808                 break;
2809             }
2810                 if (o->op_private & OPpMAYBE_LVSUB)
2811                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2812             }
2813             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2814                 if (o->op_private & OPpLVAL_DEFER)
2815                     sv_catpv(tmpsv, ",LVAL_DEFER");
2816             }
2817             else {
2818                 if (o->op_private & HINT_STRICT_REFS)
2819                     sv_catpv(tmpsv, ",STRICT_REFS");
2820                 if (o->op_private & OPpOUR_INTRO)
2821                     sv_catpv(tmpsv, ",OUR_INTRO");
2822             }
2823         }
2824         else if (o->op_type == OP_CONST) {
2825             if (o->op_private & OPpCONST_BARE)
2826                 sv_catpv(tmpsv, ",BARE");
2827             if (o->op_private & OPpCONST_STRICT)
2828                 sv_catpv(tmpsv, ",STRICT");
2829             if (o->op_private & OPpCONST_ARYBASE)
2830                 sv_catpv(tmpsv, ",ARYBASE");
2831             if (o->op_private & OPpCONST_WARNING)
2832                 sv_catpv(tmpsv, ",WARNING");
2833             if (o->op_private & OPpCONST_ENTERED)
2834                 sv_catpv(tmpsv, ",ENTERED");
2835         }
2836         else if (o->op_type == OP_FLIP) {
2837             if (o->op_private & OPpFLIP_LINENUM)
2838                 sv_catpv(tmpsv, ",LINENUM");
2839         }
2840         else if (o->op_type == OP_FLOP) {
2841             if (o->op_private & OPpFLIP_LINENUM)
2842                 sv_catpv(tmpsv, ",LINENUM");
2843         }
2844         else if (o->op_type == OP_RV2CV) {
2845             if (o->op_private & OPpLVAL_INTRO)
2846                 sv_catpv(tmpsv, ",INTRO");
2847         }
2848         else if (o->op_type == OP_GV) {
2849             if (o->op_private & OPpEARLY_CV)
2850                 sv_catpv(tmpsv, ",EARLY_CV");
2851         }
2852         else if (o->op_type == OP_LIST) {
2853             if (o->op_private & OPpLIST_GUESSED)
2854                 sv_catpv(tmpsv, ",GUESSED");
2855         }
2856         else if (o->op_type == OP_DELETE) {
2857             if (o->op_private & OPpSLICE)
2858                 sv_catpv(tmpsv, ",SLICE");
2859         }
2860         else if (o->op_type == OP_EXISTS) {
2861             if (o->op_private & OPpEXISTS_SUB)
2862                 sv_catpv(tmpsv, ",EXISTS_SUB");
2863         }
2864         else if (o->op_type == OP_SORT) {
2865             if (o->op_private & OPpSORT_NUMERIC)
2866                 sv_catpv(tmpsv, ",NUMERIC");
2867             if (o->op_private & OPpSORT_INTEGER)
2868                 sv_catpv(tmpsv, ",INTEGER");
2869             if (o->op_private & OPpSORT_REVERSE)
2870                 sv_catpv(tmpsv, ",REVERSE");
2871         }
2872         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2873             if (o->op_private & OPpOPEN_IN_RAW)
2874                 sv_catpv(tmpsv, ",IN_RAW");
2875             if (o->op_private & OPpOPEN_IN_CRLF)
2876                 sv_catpv(tmpsv, ",IN_CRLF");
2877             if (o->op_private & OPpOPEN_OUT_RAW)
2878                 sv_catpv(tmpsv, ",OUT_RAW");
2879             if (o->op_private & OPpOPEN_OUT_CRLF)
2880                 sv_catpv(tmpsv, ",OUT_CRLF");
2881         }
2882         else if (o->op_type == OP_EXIT) {
2883             if (o->op_private & OPpEXIT_VMSISH)
2884                 sv_catpv(tmpsv, ",EXIT_VMSISH");
2885             if (o->op_private & OPpHUSH_VMSISH)
2886                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2887         }
2888         else if (o->op_type == OP_DIE) {
2889             if (o->op_private & OPpHUSH_VMSISH)
2890                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2891         }
2892         else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2893             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2894                 sv_catpv(tmpsv, ",FT_ACCESS");
2895             if (o->op_private & OPpFT_STACKED)
2896                 sv_catpv(tmpsv, ",FT_STACKED");
2897         }
2898         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2899             sv_catpv(tmpsv, ",INTRO");
2900         if (SvCUR(tmpsv))
2901             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2902         SvREFCNT_dec(tmpsv);
2903     }
2904
2905     switch (o->op_type) {
2906     case OP_AELEMFAST:
2907         if (o->op_flags & OPf_SPECIAL) {
2908             break;
2909         }
2910     case OP_GVSV:
2911     case OP_GV:
2912 #ifdef USE_ITHREADS
2913         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2914 #else
2915         if (cSVOPo->op_sv) {
2916             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2917             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2918             char *s;
2919             STRLEN len;
2920             ENTER;
2921             SAVEFREESV(tmpsv1);
2922             SAVEFREESV(tmpsv2);
2923             gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2924             s = SvPV(tmpsv1,len);
2925             sv_catxmlpvn(tmpsv2, s, len, 1);
2926             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2927             LEAVE;
2928         }
2929         else
2930             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2931 #endif
2932         break;
2933     case OP_CONST:
2934     case OP_HINTSEVAL:
2935     case OP_METHOD_NAMED:
2936 #ifndef USE_ITHREADS
2937         /* with ITHREADS, consts are stored in the pad, and the right pad
2938          * may not be active here, so skip */
2939         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2940 #endif
2941         break;
2942     case OP_ANONCODE:
2943         if (!contents) {
2944             contents = 1;
2945             PerlIO_printf(file, ">\n");
2946         }
2947         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2948         break;
2949     case OP_NEXTSTATE:
2950     case OP_DBSTATE:
2951         if (CopLINE(cCOPo))
2952             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2953                              (UV)CopLINE(cCOPo));
2954         if (CopSTASHPV(cCOPo))
2955             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2956                              CopSTASHPV(cCOPo));
2957         if (CopLABEL(cCOPo))
2958             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2959                              CopLABEL(cCOPo));
2960         break;
2961     case OP_ENTERLOOP:
2962         S_xmldump_attr(aTHX_ level, file, "redo=\"");
2963         if (cLOOPo->op_redoop)
2964             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2965         else
2966             PerlIO_printf(file, "DONE\"");
2967         S_xmldump_attr(aTHX_ level, file, "next=\"");
2968         if (cLOOPo->op_nextop)
2969             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2970         else
2971             PerlIO_printf(file, "DONE\"");
2972         S_xmldump_attr(aTHX_ level, file, "last=\"");
2973         if (cLOOPo->op_lastop)
2974             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2975         else
2976             PerlIO_printf(file, "DONE\"");
2977         break;
2978     case OP_COND_EXPR:
2979     case OP_RANGE:
2980     case OP_MAPWHILE:
2981     case OP_GREPWHILE:
2982     case OP_OR:
2983     case OP_AND:
2984         S_xmldump_attr(aTHX_ level, file, "other=\"");
2985         if (cLOGOPo->op_other)
2986             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2987         else
2988             PerlIO_printf(file, "DONE\"");
2989         break;
2990     case OP_LEAVE:
2991     case OP_LEAVEEVAL:
2992     case OP_LEAVESUB:
2993     case OP_LEAVESUBLV:
2994     case OP_LEAVEWRITE:
2995     case OP_SCOPE:
2996         if (o->op_private & OPpREFCOUNTED)
2997             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2998         break;
2999     default:
3000         break;
3001     }
3002
3003     if (PL_madskills && o->op_madprop) {
3004         char prevkey = '\0';
3005         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3006         const MADPROP* mp = o->op_madprop;
3007
3008         if (!contents) {
3009             contents = 1;
3010             PerlIO_printf(file, ">\n");
3011         }
3012         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3013         level++;
3014         while (mp) {
3015             char tmp = mp->mad_key;
3016             sv_setpvs(tmpsv,"\"");
3017             if (tmp)
3018                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3019             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3020                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3021             else
3022                 prevkey = tmp;
3023             sv_catpv(tmpsv, "\"");
3024             switch (mp->mad_type) {
3025             case MAD_NULL:
3026                 sv_catpv(tmpsv, "NULL");
3027                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3028                 break;
3029             case MAD_PV:
3030                 sv_catpv(tmpsv, " val=\"");
3031                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3032                 sv_catpv(tmpsv, "\"");
3033                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3034                 break;
3035             case MAD_SV:
3036                 sv_catpv(tmpsv, " val=\"");
3037                 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3038                 sv_catpv(tmpsv, "\"");
3039                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3040                 break;
3041             case MAD_OP:
3042                 if ((OP*)mp->mad_val) {
3043                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3044                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3045                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3046                 }
3047                 break;
3048             default:
3049                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3050                 break;
3051             }
3052             mp = mp->mad_next;
3053         }
3054         level--;
3055         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3056
3057         SvREFCNT_dec(tmpsv);
3058     }
3059
3060     switch (o->op_type) {
3061     case OP_PUSHRE:
3062     case OP_MATCH:
3063     case OP_QR:
3064     case OP_SUBST:
3065         if (!contents) {
3066             contents = 1;
3067             PerlIO_printf(file, ">\n");
3068         }
3069         do_pmop_xmldump(level, file, cPMOPo);
3070         break;
3071     default:
3072         break;
3073     }
3074
3075     if (o->op_flags & OPf_KIDS) {
3076         OP *kid;
3077         if (!contents) {
3078             contents = 1;
3079             PerlIO_printf(file, ">\n");
3080         }
3081         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3082             do_op_xmldump(level, file, kid);
3083     }
3084
3085     if (contents)
3086         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3087     else
3088         PerlIO_printf(file, " />\n");
3089 }
3090
3091 void
3092 Perl_op_xmldump(pTHX_ const OP *o)
3093 {
3094     PERL_ARGS_ASSERT_OP_XMLDUMP;
3095
3096     do_op_xmldump(0, PL_xmlfp, o);
3097 }
3098 #endif
3099
3100 /*
3101  * Local variables:
3102  * c-indentation-style: bsd
3103  * c-basic-offset: 4
3104  * indent-tabs-mode: t
3105  * End:
3106  *
3107  * ex: set ts=8 sts=4 sw=4 noet:
3108  */