dump.c

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