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