dump.c

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