dump.c

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