dump.c

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