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