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