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