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