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