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