dump.c

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