dump.c

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