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