dump.c

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