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