dump.c

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