dump.c

   1 /*    dump.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
  13  * it has not been hard for me to read your mind and memory.'"
  14  */
  15
  16 /* This file contains utility routines to dump the contents of SV and OP
  17  * structures, as used by command-line options like -Dt and -Dx, and
  18  * by Devel::Peek.
  19  *
  20  * It also holds the debugging version of the  runops function.
  21  */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_DUMP_C
  25 #include "perl.h"
  26 #include "regcomp.h"
  27 #include "proto.h"
  28
  29
  30 static const char* const svtypenames[SVt_LAST] = {
  31     "NULL",
  32     "IV",
  33     "NV",
  34     "RV",
  35     "BIND",
  36     "PV",
  37     "PVIV",
  38     "PVNV",
  39     "PVMG",
  40     "PVGV",
  41     "PVLV",
  42     "PVAV",
  43     "PVHV",
  44     "PVCV",
  45     "PVFM",
  46     "PVIO"
  47 };
  48
  49
  50 static const char* const svshorttypenames[SVt_LAST] = {
  51     "UNDEF",
  52     "IV",
  53     "NV",
  54     "RV",
  55     "BIND",
  56     "PV",
  57     "PVIV",
  58     "PVNV",
  59     "PVMG",
  60     "GV",
  61     "PVLV",
  62     "AV",
  63     "HV",
  64     "CV",
  65     "FM",
  66     "IO"
  67 };
  68
  69 #define Sequence PL_op_sequence
  70
  71 void
  72 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
  73 {
  74     va_list args;
  75     va_start(args, pat);
  76     dump_vindent(level, file, pat, &args);
  77     va_end(args);
  78 }
  79
  80 void
  81 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
  82 {
  83     dVAR;
  84     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
  85     PerlIO_vprintf(file, pat, *args);
  86 }
  87
  88 void
  89 Perl_dump_all(pTHX)
  90 {
  91     dVAR;
  92     PerlIO_setlinebuf(Perl_debug_log);
  93     if (PL_main_root)
  94         op_dump(PL_main_root);
  95     dump_packsubs(PL_defstash);
  96 }
  97
  98 void
  99 Perl_dump_packsubs(pTHX_ const HV *stash)
 100 {
 101     dVAR;
 102     I32 i;
 103
 104     if (!HvARRAY(stash))
 105         return;
 106     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 107         const HE *entry;
 108         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 109             const GV *gv = (GV*)HeVAL(entry);
 110             const HV *hv;
 111             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 112                 continue;
 113             if (GvCVu(gv))
 114                 dump_sub(gv);
 115             if (GvFORM(gv))
 116                 dump_form(gv);
 117             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
 118                 && (hv = GvHV(gv)) && hv != PL_defstash)
 119                 dump_packsubs(hv);              /* nested package */
 120         }
 121     }
 122 }
 123
 124 void
 125 Perl_dump_sub(pTHX_ const GV *gv)
 126 {
 127     SV * const sv = sv_newmortal();
 128
 129     gv_fullname3(sv, gv, NULL);
 130     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
 131     if (CvISXSUB(GvCV(gv)))
 132         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
 133             PTR2UV(CvXSUB(GvCV(gv))),
 134             (int)CvXSUBANY(GvCV(gv)).any_i32);
 135     else if (CvROOT(GvCV(gv)))
 136         op_dump(CvROOT(GvCV(gv)));
 137     else
 138         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 139 }
 140
 141 void
 142 Perl_dump_form(pTHX_ const GV *gv)
 143 {
 144     SV * const sv = sv_newmortal();
 145
 146     gv_fullname3(sv, gv, NULL);
 147     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
 148     if (CvROOT(GvFORM(gv)))
 149         op_dump(CvROOT(GvFORM(gv)));
 150     else
 151         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 152 }
 153
 154 void
 155 Perl_dump_eval(pTHX)
 156 {
 157     dVAR;
 158     op_dump(PL_eval_root);
 159 }
 160
 161
 162 /*
 163 =for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\
 164                |const STRLEN count|const STRLEN max
 165                |STRLEN const *escaped, const U32 flags
 166
 167 Escapes at most the first "count" chars of pv and puts the results into
 168 dsv such that the size of the escaped string will not exceed "max" chars
 169 and will not contain any incomplete escape sequences.
 170
 171 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
 172 will also be escaped.
 173
 174 Normally the SV will be cleared before the escaped string is prepared,
 175 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
 176
 177 If PERL_PV_ESCAPE_UNI is set then the input string is treated as unicode,
 178 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
 179 using C<is_utf8_string()> to determine if it is unicode.
 180
 181 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
 182 using C<\x01F1> style escapes, otherwise only chars above 255 will be
 183 escaped using this style, other non printable chars will use octal or
 184 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
 185 then all chars below 255 will be treated as printable and
 186 will be output as literals.
 187
 188 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
 189 string will be escaped, regardles of max. If the string is utf8 and
 190 the chars value is >255 then it will be returned as a plain hex
 191 sequence. Thus the output will either be a single char,
 192 an octal escape sequence, a special escape like C<\n> or a 3 or
 193 more digit hex value.
 194
 195 Returns a pointer to the escaped text as held by dsv.
 196
 197 =cut
 198 */
 199 #define PV_ESCAPE_OCTBUFSIZE 32
 200
 201 char *
 202 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
 203                 const STRLEN count, const STRLEN max,
 204                 STRLEN * const escaped, const U32 flags )
 205 {
 206     char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
 207     char octbuf[PV_ESCAPE_OCTBUFSIZE] = "\\123456789ABCDF";
 208     STRLEN wrote = 0;    /* chars written so far */
 209     STRLEN chsize = 0;   /* size of data to be written */
 210     STRLEN readsize = 1; /* size of data just read */
 211     bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
 212     const char *pv  = str;
 213     const char *end = pv + count; /* end of string */
 214
 215     if (!flags & PERL_PV_ESCAPE_NOCLEAR)
 216             sv_setpvn(dsv, "", 0);
 217
 218     if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
 219         isuni = 1;
 220
 221     for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
 222         const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
 223         const U8 c = (U8)u & 0xFF;
 224
 225         if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
 226             if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
 227                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 228                                       "%"UVxf, u);
 229             else
 230                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 231                                       "\\x{%"UVxf"}", u);
 232         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
 233             chsize = 1;
 234         } else {
 235             if ( (c == dq) || (c == '\\') || !isPRINT(c) ) {
 236             chsize = 2;
 237                 switch (c) {
 238                 case '\\' : octbuf[1] = '\\'; break;
 239                 case '\v' : octbuf[1] = 'v';  break;
 240                 case '\t' : octbuf[1] = 't';  break;
 241                 case '\r' : octbuf[1] = 'r';  break;
 242                 case '\n' : octbuf[1] = 'n';  break;
 243                 case '\f' : octbuf[1] = 'f';  break;
 244                     case '"'  :
 245                         if ( dq == '"' )
 246                                 octbuf[1] = '"';
 247                         else
 248                             chsize = 1;
 249                                 break;
 250                 default:
 251                         if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
 252                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 253                                                   "\\%03o", c);
 254                             else
 255                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 256                                                   "\\%o", c);
 257                 }
 258             } else {
 259                 chsize=1;
 260             }
 261             }
 262             if ( max && (wrote + chsize > max) ) {
 263                 break;
 264         } else if (chsize > 1) {
 265                 sv_catpvn(dsv, octbuf, chsize);
 266                 wrote += chsize;
 267         } else {
 268             Perl_sv_catpvf( aTHX_ dsv, "%c", c);
 269             wrote++;
 270         }
 271         if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
 272             break;
 273     }
 274     if (escaped != NULL)
 275         *escaped= pv - str;
 276     return SvPVX(dsv);
 277 }
 278 /*
 279 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
 280            |const STRLEN count|const STRLEN max\
 281            |const char const *start_color| const char const *end_color\
 282            |const U32 flags
 283
 284 Converts a string into something presentable, handling escaping via
 285 pv_escape() and supporting quoting and elipses.
 286
 287 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
 288 double quoted with any double quotes in the string escaped. Otherwise
 289 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
 290 angle brackets.
 291
 292 If the PERL_PV_PRETTY_ELIPSES flag is set and not all characters in
 293 string were output then an elipses C<...> will be appended to the
 294 string. Note that this happens AFTER it has been quoted.
 295
 296 If start_color is non-null then it will be inserted after the opening
 297 quote (if there is one) but before the escaped text. If end_color
 298 is non-null then it will be inserted after the escaped text but before
 299 any quotes or elipses.
 300
 301 Returns a pointer to the prettified text as held by dsv.
 302
 303 =cut
 304 */
 305
 306 char *
 307 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
 308   const STRLEN max, char const * const start_color, char const * const end_color,
 309   const U32 flags )
 310 {
 311     U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '\\';
 312     STRLEN escaped;
 313
 314     if ( dq == '"' )
 315         sv_setpvn(dsv, "\"", 1);
 316     else if ( flags & PERL_PV_PRETTY_LTGT )
 317         sv_setpvn(dsv, "<", 1);
 318     else
 319         sv_setpvn(dsv, "", 0);
 320
 321     if ( start_color != NULL )
 322         Perl_sv_catpv( aTHX_ dsv, start_color);
 323
 324     pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
 325
 326     if ( end_color != NULL )
 327         Perl_sv_catpv( aTHX_ dsv, end_color);
 328
 329     if ( dq == '"' )
 330         sv_catpvn( dsv, "\"", 1 );
 331     else if ( flags & PERL_PV_PRETTY_LTGT )
 332         sv_catpvn( dsv, ">", 1);
 333
 334     if ( (flags & PERL_PV_PRETTY_ELIPSES) && ( escaped < count ) )
 335             sv_catpvn( dsv, "...", 3 );
 336
 337     return SvPVX(dsv);
 338 }
 339
 340 /*
 341 =for apidoc pv_display
 342
 343   char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
 344                    STRLEN pvlim, U32 flags)
 345
 346 Similar to
 347
 348   pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
 349
 350 except that an additional "\0" will be appended to the string when
 351 len > cur and pv[cur] is "\0".
 352
 353 Note that the final string may be up to 7 chars longer than pvlim.
 354
 355 =cut
 356 */
 357
 358 char *
 359 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
 360 {
 361     pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
 362     if (len > cur && pv[cur] == '\0')
 363             sv_catpvn( dsv, "\\0", 2 );
 364     return SvPVX(dsv);
 365 }
 366
 367 char *
 368 Perl_sv_peek(pTHX_ SV *sv)
 369 {
 370     dVAR;
 371     SV * const t = sv_newmortal();
 372     int unref = 0;
 373     U32 type;
 374
 375     sv_setpvn(t, "", 0);
 376   retry:
 377     if (!sv) {
 378         sv_catpv(t, "VOID");
 379         goto finish;
 380     }
 381     else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
 382         sv_catpv(t, "WILD");
 383         goto finish;
 384     }
 385     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
 386         if (sv == &PL_sv_undef) {
 387             sv_catpv(t, "SV_UNDEF");
 388             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 389                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 390                 SvREADONLY(sv))
 391                 goto finish;
 392         }
 393         else if (sv == &PL_sv_no) {
 394             sv_catpv(t, "SV_NO");
 395             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 396                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 397                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 398                                   SVp_POK|SVp_NOK)) &&
 399                 SvCUR(sv) == 0 &&
 400                 SvNVX(sv) == 0.0)
 401                 goto finish;
 402         }
 403         else if (sv == &PL_sv_yes) {
 404             sv_catpv(t, "SV_YES");
 405             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 406                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 407                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 408                                   SVp_POK|SVp_NOK)) &&
 409                 SvCUR(sv) == 1 &&
 410                 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
 411                 SvNVX(sv) == 1.0)
 412                 goto finish;
 413         }
 414         else {
 415             sv_catpv(t, "SV_PLACEHOLDER");
 416             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 417                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 418                 SvREADONLY(sv))
 419                 goto finish;
 420         }
 421         sv_catpv(t, ":");
 422     }
 423     else if (SvREFCNT(sv) == 0) {
 424         sv_catpv(t, "(");
 425         unref++;
 426     }
 427     else if (DEBUG_R_TEST_) {
 428         int is_tmp = 0;
 429         I32 ix;
 430         /* is this SV on the tmps stack? */
 431         for (ix=PL_tmps_ix; ix>=0; ix--) {
 432             if (PL_tmps_stack[ix] == sv) {
 433                 is_tmp = 1;
 434                 break;
 435             }
 436         }
 437         if (SvREFCNT(sv) > 1)
 438             Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
 439                     is_tmp ? "T" : "");
 440         else if (is_tmp)
 441             sv_catpv(t, "<T>");
 442     }
 443
 444     if (SvROK(sv)) {
 445         sv_catpv(t, "\\");
 446         if (SvCUR(t) + unref > 10) {
 447             SvCUR_set(t, unref + 3);
 448             *SvEND(t) = '\0';
 449             sv_catpv(t, "...");
 450             goto finish;
 451         }
 452         sv = (SV*)SvRV(sv);
 453         goto retry;
 454     }
 455     type = SvTYPE(sv);
 456     if (type == SVt_PVCV) {
 457         Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
 458         goto finish;
 459     } else if (type < SVt_LAST) {
 460         sv_catpv(t, svshorttypenames[type]);
 461
 462         if (type == SVt_NULL)
 463             goto finish;
 464     } else {
 465         sv_catpv(t, "FREED");
 466         goto finish;
 467     }
 468
 469     if (SvPOKp(sv)) {
 470         if (!SvPVX_const(sv))
 471             sv_catpv(t, "(null)");
 472         else {
 473             SV * const tmp = newSVpvs("");
 474             sv_catpv(t, "(");
 475             if (SvOOK(sv))
 476                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
 477             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
 478             if (SvUTF8(sv))
 479                 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
 480                                sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv),
 481                                               UNI_DISPLAY_QQ));
 482             SvREFCNT_dec(tmp);
 483         }
 484     }
 485     else if (SvNOKp(sv)) {
 486         STORE_NUMERIC_LOCAL_SET_STANDARD();
 487         Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
 488         RESTORE_NUMERIC_LOCAL();
 489     }
 490     else if (SvIOKp(sv)) {
 491         if (SvIsUV(sv))
 492             Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
 493         else
 494             Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
 495     }
 496     else
 497         sv_catpv(t, "()");
 498
 499   finish:
 500     if (unref) {
 501         while (unref--)
 502             sv_catpv(t, ")");
 503     }
 504     return SvPV_nolen(t);
 505 }
 506
 507 void
 508 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
 509 {
 510     char ch;
 511
 512     if (!pm) {
 513         Perl_dump_indent(aTHX_ level, file, "{}\n");
 514         return;
 515     }
 516     Perl_dump_indent(aTHX_ level, file, "{\n");
 517     level++;
 518     if (pm->op_pmflags & PMf_ONCE)
 519         ch = '?';
 520     else
 521         ch = '/';
 522     if (PM_GETRE(pm))
 523         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
 524              ch, PM_GETRE(pm)->precomp, ch,
 525              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
 526     else
 527         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
 528     if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
 529         Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
 530         op_dump(pm->op_pmreplroot);
 531     }
 532     if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
 533         SV * const tmpsv = pm_description(pm);
 534         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 535         SvREFCNT_dec(tmpsv);
 536     }
 537
 538     Perl_dump_indent(aTHX_ level-1, file, "}\n");
 539 }
 540
 541 static SV *
 542 S_pm_description(pTHX_ const PMOP *pm)
 543 {
 544     SV * const desc = newSVpvs("");
 545     const REGEXP * regex = PM_GETRE(pm);
 546     const U32 pmflags = pm->op_pmflags;
 547
 548     if (pm->op_pmdynflags & PMdf_USED)
 549         sv_catpv(desc, ",USED");
 550     if (pm->op_pmdynflags & PMdf_TAINTED)
 551         sv_catpv(desc, ",TAINTED");
 552
 553     if (pmflags & PMf_ONCE)
 554         sv_catpv(desc, ",ONCE");
 555     if (regex && regex->check_substr) {
 556         if (!(regex->extflags & RXf_NOSCAN))
 557             sv_catpv(desc, ",SCANFIRST");
 558         if (regex->extflags & RXf_CHECK_ALL)
 559             sv_catpv(desc, ",ALL");
 560     }
 561     if (pmflags & PMf_SKIPWHITE)
 562         sv_catpv(desc, ",SKIPWHITE");
 563     if (pmflags & PMf_CONST)
 564         sv_catpv(desc, ",CONST");
 565     if (pmflags & PMf_KEEP)
 566         sv_catpv(desc, ",KEEP");
 567     if (pmflags & PMf_GLOBAL)
 568         sv_catpv(desc, ",GLOBAL");
 569     if (pmflags & PMf_CONTINUE)
 570         sv_catpv(desc, ",CONTINUE");
 571     if (pmflags & PMf_RETAINT)
 572         sv_catpv(desc, ",RETAINT");
 573     if (pmflags & PMf_EVAL)
 574         sv_catpv(desc, ",EVAL");
 575     return desc;
 576 }
 577
 578 void
 579 Perl_pmop_dump(pTHX_ PMOP *pm)
 580 {
 581     do_pmop_dump(0, Perl_debug_log, pm);
 582 }
 583
 584 /* An op sequencer.  We visit the ops in the order they're to execute. */
 585
 586 STATIC void
 587 S_sequence(pTHX_ register const OP *o)
 588 {
 589     dVAR;
 590     const OP *oldop = NULL;
 591
 592     if (!o)
 593         return;
 594
 595 #ifdef PERL_MAD
 596     if (o->op_next == 0)
 597         return;
 598 #endif
 599
 600     if (!Sequence)
 601         Sequence = newHV();
 602
 603     for (; o; o = o->op_next) {
 604         STRLEN len;
 605         SV * const op = newSVuv(PTR2UV(o));
 606         const char * const key = SvPV_const(op, len);
 607
 608         if (hv_exists(Sequence, key, len))
 609             break;
 610
 611         switch (o->op_type) {
 612         case OP_STUB:
 613             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
 614                 hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 615                 break;
 616             }
 617             goto nothin;
 618         case OP_NULL:
 619 #ifdef PERL_MAD
 620             if (o == o->op_next)
 621                 return;
 622 #endif
 623             if (oldop && o->op_next)
 624                 continue;
 625             break;
 626         case OP_SCALAR:
 627         case OP_LINESEQ:
 628         case OP_SCOPE:
 629           nothin:
 630             if (oldop && o->op_next)
 631                 continue;
 632             hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 633             break;
 634
 635         case OP_MAPWHILE:
 636         case OP_GREPWHILE:
 637         case OP_AND:
 638         case OP_OR:
 639         case OP_DOR:
 640         case OP_ANDASSIGN:
 641         case OP_ORASSIGN:
 642         case OP_DORASSIGN:
 643         case OP_COND_EXPR:
 644         case OP_RANGE:
 645             hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 646             sequence_tail(cLOGOPo->op_other);
 647             break;
 648
 649         case OP_ENTERLOOP:
 650         case OP_ENTERITER:
 651             hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 652             sequence_tail(cLOOPo->op_redoop);
 653             sequence_tail(cLOOPo->op_nextop);
 654             sequence_tail(cLOOPo->op_lastop);
 655             break;
 656
 657         case OP_QR:
 658         case OP_MATCH:
 659         case OP_SUBST:
 660             hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 661             sequence_tail(cPMOPo->op_pmreplstart);
 662             break;
 663
 664         case OP_HELEM:
 665             break;
 666
 667         default:
 668             hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 669             break;
 670         }
 671         oldop = o;
 672     }
 673 }
 674
 675 static void
 676 S_sequence_tail(pTHX_ const OP *o)
 677 {
 678     while (o && (o->op_type == OP_NULL))
 679         o = o->op_next;
 680     sequence(o);
 681 }
 682
 683 STATIC UV
 684 S_sequence_num(pTHX_ const OP *o)
 685 {
 686     dVAR;
 687     SV     *op,
 688           **seq;
 689     const char *key;
 690     STRLEN  len;
 691     if (!o) return 0;
 692     op = newSVuv(PTR2UV(o));
 693     key = SvPV_const(op, len);
 694     seq = hv_fetch(Sequence, key, len, 0);
 695     return seq ? SvUV(*seq): 0;
 696 }
 697
 698 void
 699 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 700 {
 701     dVAR;
 702     UV      seq;
 703     const OPCODE optype = o->op_type;
 704
 705     sequence(o);
 706     Perl_dump_indent(aTHX_ level, file, "{\n");
 707     level++;
 708     seq = sequence_num(o);
 709     if (seq)
 710         PerlIO_printf(file, "%-4"UVuf, seq);
 711     else
 712         PerlIO_printf(file, "    ");
 713     PerlIO_printf(file,
 714                   "%*sTYPE = %s  ===> ",
 715                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
 716     if (o->op_next)
 717         PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
 718                                 sequence_num(o->op_next));
 719     else
 720         PerlIO_printf(file, "DONE\n");
 721     if (o->op_targ) {
 722         if (optype == OP_NULL) {
 723             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
 724             if (o->op_targ == OP_NEXTSTATE) {
 725                 if (CopLINE(cCOPo))
 726                     Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
 727                                      (UV)CopLINE(cCOPo));
 728                 if (CopSTASHPV(cCOPo))
 729                     Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
 730                                      CopSTASHPV(cCOPo));
 731                 if (cCOPo->cop_label)
 732                     Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
 733                                      cCOPo->cop_label);
 734             }
 735         }
 736         else
 737             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
 738     }
 739 #ifdef DUMPADDR
 740     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
 741 #endif
 742     if (o->op_flags) {
 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         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1433         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1434         /* FALL THROUGH */
1435     default:
1436     evaled_or_uv:
1437         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1438         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1439         break;
1440     case SVt_PVMG:
1441         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1442         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1443         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1444         break;
1445     case SVt_PVNV:
1446         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1447         goto evaled_or_uv;
1448     case SVt_PVAV:
1449         break;
1450     }
1451     /* SVphv_SHAREKEYS is also 0x20000000 */
1452     if ((type != SVt_PVHV) && SvUTF8(sv))
1453         sv_catpv(d, "UTF8");
1454
1455     if (*(SvEND(d) - 1) == ',') {
1456         SvCUR_set(d, SvCUR(d) - 1);
1457         SvPVX(d)[SvCUR(d)] = '\0';
1458     }
1459     sv_catpv(d, ")");
1460     s = SvPVX_const(d);
1461
1462 #ifdef DEBUG_LEAKING_SCALARS
1463     Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1464         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1465         sv->sv_debug_line,
1466         sv->sv_debug_inpad ? "for" : "by",
1467         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1468         sv->sv_debug_cloned ? " (cloned)" : "");
1469 #endif
1470     Perl_dump_indent(aTHX_ level, file, "SV = ");
1471     if (type < SVt_LAST) {
1472         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1473
1474         if (type ==  SVt_NULL) {
1475             SvREFCNT_dec(d);
1476             return;
1477         }
1478     } else {
1479         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1480         SvREFCNT_dec(d);
1481         return;
1482     }
1483     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1484          && type != SVt_PVCV && !isGV_with_GP(sv))
1485         || type == SVt_IV) {
1486         if (SvIsUV(sv)
1487 #ifdef PERL_OLD_COPY_ON_WRITE
1488                        || SvIsCOW(sv)
1489 #endif
1490                                      )
1491             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1492         else
1493             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1494         if (SvOOK(sv))
1495             PerlIO_printf(file, "  (OFFSET)");
1496 #ifdef PERL_OLD_COPY_ON_WRITE
1497         if (SvIsCOW_shared_hash(sv))
1498             PerlIO_printf(file, "  (HASH)");
1499         else if (SvIsCOW_normal(sv))
1500             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1501 #endif
1502         PerlIO_putc(file, '\n');
1503     }
1504     if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1505          && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv))
1506         || type == SVt_NV) {
1507         STORE_NUMERIC_LOCAL_SET_STANDARD();
1508         /* %Vg doesn't work? --jhi */
1509 #ifdef USE_LONG_DOUBLE
1510         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1511 #else
1512         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1513 #endif
1514         RESTORE_NUMERIC_LOCAL();
1515     }
1516     if (SvROK(sv)) {
1517         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1518         if (nest < maxnest)
1519             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1520     }
1521     if (type < SVt_PV) {
1522         SvREFCNT_dec(d);
1523         return;
1524     }
1525     if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1526         if (SvPVX_const(sv)) {
1527             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1528             if (SvOOK(sv))
1529                 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1530             PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1531             if (SvUTF8(sv)) /* the 8?  \x{....} */
1532                 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1533             PerlIO_printf(file, "\n");
1534             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1535             Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
1536         }
1537         else
1538             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1539     }
1540     if (type >= SVt_PVMG) {
1541         if (SvMAGIC(sv))
1542             do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1543         if (SvSTASH(sv))
1544             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1545     }
1546     switch (type) {
1547     case SVt_PVAV:
1548         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1549         if (AvARRAY(sv) != AvALLOC(sv)) {
1550             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1551             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1552         }
1553         else
1554             PerlIO_putc(file, '\n');
1555         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1556         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1557         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1558         sv_setpvn(d, "", 0);
1559         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1560         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1561         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1562                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1563         if (nest < maxnest && av_len((AV*)sv) >= 0) {
1564             int count;
1565             for (count = 0; count <=  av_len((AV*)sv) && count < maxnest; count++) {
1566                 SV** elt = av_fetch((AV*)sv,count,0);
1567
1568                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1569                 if (elt)
1570                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1571             }
1572         }
1573         break;
1574     case SVt_PVHV:
1575         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1576         if (HvARRAY(sv) && HvKEYS(sv)) {
1577             /* Show distribution of HEs in the ARRAY */
1578             int freq[200];
1579 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1580             int i;
1581             int max = 0;
1582             U32 pow2 = 2, keys = HvKEYS(sv);
1583             NV theoret, sum = 0;
1584
1585             PerlIO_printf(file, "  (");
1586             Zero(freq, FREQ_MAX + 1, int);
1587             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1588                 HE* h;
1589                 int count = 0;
1590                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1591                     count++;
1592                 if (count > FREQ_MAX)
1593                     count = FREQ_MAX;
1594                 freq[count]++;
1595                 if (max < count)
1596                     max = count;
1597             }
1598             for (i = 0; i <= max; i++) {
1599                 if (freq[i]) {
1600                     PerlIO_printf(file, "%d%s:%d", i,
1601                                   (i == FREQ_MAX) ? "+" : "",
1602                                   freq[i]);
1603                     if (i != max)
1604                         PerlIO_printf(file, ", ");
1605                 }
1606             }
1607             PerlIO_putc(file, ')');
1608             /* The "quality" of a hash is defined as the total number of
1609                comparisons needed to access every element once, relative
1610                to the expected number needed for a random hash.
1611
1612                The total number of comparisons is equal to the sum of
1613                the squares of the number of entries in each bucket.
1614                For a random hash of n keys into k buckets, the expected
1615                value is
1616                                 n + n(n-1)/2k
1617             */
1618
1619             for (i = max; i > 0; i--) { /* Precision: count down. */
1620                 sum += freq[i] * i * i;
1621             }
1622             while ((keys = keys >> 1))
1623                 pow2 = pow2 << 1;
1624             theoret = HvKEYS(sv);
1625             theoret += theoret * (theoret-1)/pow2;
1626             PerlIO_putc(file, '\n');
1627             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1628         }
1629         PerlIO_putc(file, '\n');
1630         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1631         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1632         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1633         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1634         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1635         {
1636             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1637             if (mg && mg->mg_obj) {
1638                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1639             }
1640         }
1641         {
1642             const char * const hvname = HvNAME_get(sv);
1643             if (hvname)
1644                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1645         }
1646         if (SvOOK(sv)) {
1647             const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1648             if (backrefs) {
1649                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1650                                  PTR2UV(backrefs));
1651                 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1652                            dumpops, pvlim);
1653             }
1654         }
1655         if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1656             HE *he;
1657             HV * const hv = (HV*)sv;
1658             int count = maxnest - nest;
1659
1660             hv_iterinit(hv);
1661             while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1662                    && count--) {
1663                 SV *elt, *keysv;
1664                 const char *keypv;
1665                 STRLEN len;
1666                 const U32 hash = HeHASH(he);
1667
1668                 keysv = hv_iterkeysv(he);
1669                 keypv = SvPV_const(keysv, len);
1670                 elt = hv_iterval(hv, he);
1671                 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1672                 if (SvUTF8(keysv))
1673                     PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1674                 if (HeKREHASH(he))
1675                     PerlIO_printf(file, "[REHASH] ");
1676                 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1677                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1678             }
1679             hv_iterinit(hv);            /* Return to status quo */
1680         }
1681         break;
1682     case SVt_PVCV:
1683         if (SvPOK(sv)) {
1684             STRLEN len;
1685             const char *const proto =  SvPV_const(sv, len);
1686             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1687                              (int) len, proto);
1688         }
1689         /* FALL THROUGH */
1690     case SVt_PVFM:
1691         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1692         if (!CvISXSUB(sv)) {
1693             if (CvSTART(sv)) {
1694                 Perl_dump_indent(aTHX_ level, file,
1695                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1696                                  PTR2UV(CvSTART(sv)),
1697                                  (IV)sequence_num(CvSTART(sv)));
1698             }
1699             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1700                              PTR2UV(CvROOT(sv)));
1701             if (CvROOT(sv) && dumpops) {
1702                 do_op_dump(level+1, file, CvROOT(sv));
1703             }
1704         } else {
1705             SV *constant = cv_const_sv((CV *)sv);
1706
1707             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1708
1709             if (constant) {
1710                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1711                                  " (CONST SV)\n",
1712                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1713                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1714                            pvlim);
1715             } else {
1716                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1717                                  (IV)CvXSUBANY(sv).any_i32);
1718             }
1719         }
1720         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1721         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1722         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1723         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1724         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1725         if (type == SVt_PVFM)
1726             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
1727         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1728         if (nest < maxnest) {
1729             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1730         }
1731         {
1732             const CV * const outside = CvOUTSIDE(sv);
1733             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1734                         PTR2UV(outside),
1735                         (!outside ? "null"
1736                          : CvANON(outside) ? "ANON"
1737                          : (outside == PL_main_cv) ? "MAIN"
1738                          : CvUNIQUE(outside) ? "UNIQUE"
1739                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1740         }
1741         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1742             do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1743         break;
1744     case SVt_PVGV:
1745     case SVt_PVLV:
1746         if (type == SVt_PVLV) {
1747             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
1748             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1749             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1750             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1751             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1752                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1753                     dumpops, pvlim);
1754         }
1755         if (!isGV_with_GP(sv))
1756             break;
1757         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
1758         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1759         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
1760         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1761         if (!GvGP(sv))
1762             break;
1763         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1764         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1765         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1766         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
1767         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1768         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1769         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1770         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1771         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
1772         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
1773         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1774         do_gv_dump (level, file, "    EGV", GvEGV(sv));
1775         break;
1776     case SVt_PVIO:
1777         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1778         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1779         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1780         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
1781         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1782         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1783         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1784         if (IoTOP_NAME(sv))
1785             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1786         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1787             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
1788         else {
1789             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
1790                              PTR2UV(IoTOP_GV(sv)));
1791             do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1792                         dumpops, pvlim);
1793         }
1794         /* Source filters hide things that are not GVs in these three, so let's
1795            be careful out there.  */
1796         if (IoFMT_NAME(sv))
1797             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1798         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1799             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
1800         else {
1801             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
1802                              PTR2UV(IoFMT_GV(sv)));
1803             do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1804                         dumpops, pvlim);
1805         }
1806         if (IoBOTTOM_NAME(sv))
1807             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1808         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1809             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
1810         else {
1811             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
1812                              PTR2UV(IoBOTTOM_GV(sv)));
1813             do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1814                         dumpops, pvlim);
1815         }
1816         Perl_dump_indent(aTHX_ level, file, "  SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1817         if (isPRINT(IoTYPE(sv)))
1818             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
1819         else
1820             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
1821         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1822         break;
1823     }
1824     SvREFCNT_dec(d);
1825 }
1826
1827 void
1828 Perl_sv_dump(pTHX_ SV *sv)
1829 {
1830     dVAR;
1831     do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1832 }
1833
1834 int
1835 Perl_runops_debug(pTHX)
1836 {
1837     dVAR;
1838     if (!PL_op) {
1839         if (ckWARN_d(WARN_DEBUGGING))
1840             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1841         return 0;
1842     }
1843
1844     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1845     do {
1846         PERL_ASYNC_CHECK();
1847         if (PL_debug) {
1848             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1849                 PerlIO_printf(Perl_debug_log,
1850                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1851                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1852                               PTR2UV(*PL_watchaddr));
1853             if (DEBUG_s_TEST_) {
1854                 if (DEBUG_v_TEST_) {
1855                     PerlIO_printf(Perl_debug_log, "\n");
1856                     deb_stack_all();
1857                 }
1858                 else
1859                     debstack();
1860             }
1861
1862
1863             if (DEBUG_t_TEST_) debop(PL_op);
1864             if (DEBUG_P_TEST_) debprof(PL_op);
1865         }
1866     } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1867     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1868
1869     TAINT_NOT;
1870     return 0;
1871 }
1872
1873 I32
1874 Perl_debop(pTHX_ const OP *o)
1875 {
1876     dVAR;
1877     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1878         return 0;
1879
1880     Perl_deb(aTHX_ "%s", OP_NAME(o));
1881     switch (o->op_type) {
1882     case OP_CONST:
1883         PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1884         break;
1885     case OP_GVSV:
1886     case OP_GV:
1887         if (cGVOPo_gv) {
1888             SV * const sv = newSV(0);
1889 #ifdef PERL_MAD
1890             /* FIXME - it this making unwarranted assumptions about the
1891                UTF-8 cleanliness of the dump file handle?  */
1892             SvUTF8_on(sv);
1893 #endif
1894             gv_fullname3(sv, cGVOPo_gv, NULL);
1895             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1896             SvREFCNT_dec(sv);
1897         }
1898         else
1899             PerlIO_printf(Perl_debug_log, "(NULL)");
1900         break;
1901     case OP_PADSV:
1902     case OP_PADAV:
1903     case OP_PADHV:
1904         {
1905         /* print the lexical's name */
1906         CV * const cv = deb_curcv(cxstack_ix);
1907         SV *sv;
1908         if (cv) {
1909             AV * const padlist = CvPADLIST(cv);
1910             AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1911             sv = *av_fetch(comppad, o->op_targ, FALSE);
1912         } else
1913             sv = NULL;
1914         if (sv)
1915             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1916         else
1917             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1918         }
1919         break;
1920     default:
1921         break;
1922     }
1923     PerlIO_printf(Perl_debug_log, "\n");
1924     return 0;
1925 }
1926
1927 STATIC CV*
1928 S_deb_curcv(pTHX_ I32 ix)
1929 {
1930     dVAR;
1931     const PERL_CONTEXT * const cx = &cxstack[ix];
1932     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1933         return cx->blk_sub.cv;
1934     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1935         return PL_compcv;
1936     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1937         return PL_main_cv;
1938     else if (ix <= 0)
1939         return NULL;
1940     else
1941         return deb_curcv(ix - 1);
1942 }
1943
1944 void
1945 Perl_watch(pTHX_ char **addr)
1946 {
1947     dVAR;
1948     PL_watchaddr = addr;
1949     PL_watchok = *addr;
1950     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
1951         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
1952 }
1953
1954 STATIC void
1955 S_debprof(pTHX_ const OP *o)
1956 {
1957     dVAR;
1958     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1959         return;
1960     if (!PL_profiledata)
1961         Newxz(PL_profiledata, MAXO, U32);
1962     ++PL_profiledata[o->op_type];
1963 }
1964
1965 void
1966 Perl_debprofdump(pTHX)
1967 {
1968     dVAR;
1969     unsigned i;
1970     if (!PL_profiledata)
1971         return;
1972     for (i = 0; i < MAXO; i++) {
1973         if (PL_profiledata[i])
1974             PerlIO_printf(Perl_debug_log,
1975                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
1976                                        PL_op_name[i]);
1977     }
1978 }
1979
1980 #ifdef PERL_MAD
1981 /*
1982  *    XML variants of most of the above routines
1983  */
1984
1985 STATIC
1986 void
1987 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
1988 {
1989     va_list args;
1990     PerlIO_printf(file, "\n    ");
1991     va_start(args, pat);
1992     xmldump_vindent(level, file, pat, &args);
1993     va_end(args);
1994 }
1995
1996
1997 void
1998 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
1999 {
2000     va_list args;
2001     va_start(args, pat);
2002     xmldump_vindent(level, file, pat, &args);
2003     va_end(args);
2004 }
2005
2006 void
2007 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2008 {
2009     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2010     PerlIO_vprintf(file, pat, *args);
2011 }
2012
2013 void
2014 Perl_xmldump_all(pTHX)
2015 {
2016     PerlIO_setlinebuf(PL_xmlfp);
2017     if (PL_main_root)
2018         op_xmldump(PL_main_root);
2019     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2020         PerlIO_close(PL_xmlfp);
2021     PL_xmlfp = 0;
2022 }
2023
2024 void
2025 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2026 {
2027     I32 i;
2028     HE  *entry;
2029
2030     if (!HvARRAY(stash))
2031         return;
2032     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2033         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2034             GV *gv = (GV*)HeVAL(entry);
2035             HV *hv;
2036             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2037                 continue;
2038             if (GvCVu(gv))
2039                 xmldump_sub(gv);
2040             if (GvFORM(gv))
2041                 xmldump_form(gv);
2042             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2043                 && (hv = GvHV(gv)) && hv != PL_defstash)
2044                 xmldump_packsubs(hv);           /* nested package */
2045         }
2046     }
2047 }
2048
2049 void
2050 Perl_xmldump_sub(pTHX_ const GV *gv)
2051 {
2052     SV *sv = sv_newmortal();
2053
2054     gv_fullname3(sv, gv, Nullch);
2055     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2056     if (CvXSUB(GvCV(gv)))
2057         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2058             PTR2UV(CvXSUB(GvCV(gv))),
2059             (int)CvXSUBANY(GvCV(gv)).any_i32);
2060     else if (CvROOT(GvCV(gv)))
2061         op_xmldump(CvROOT(GvCV(gv)));
2062     else
2063         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2064 }
2065
2066 void
2067 Perl_xmldump_form(pTHX_ const GV *gv)
2068 {
2069     SV *sv = sv_newmortal();
2070
2071     gv_fullname3(sv, gv, Nullch);
2072     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2073     if (CvROOT(GvFORM(gv)))
2074         op_xmldump(CvROOT(GvFORM(gv)));
2075     else
2076         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2077 }
2078
2079 void
2080 Perl_xmldump_eval(pTHX)
2081 {
2082     op_xmldump(PL_eval_root);
2083 }
2084
2085 char *
2086 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2087 {
2088     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2089 }
2090
2091 char *
2092 Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2093 {
2094     unsigned int c;
2095     char *e = pv + len;
2096     char *start = pv;
2097     STRLEN dsvcur;
2098     STRLEN cl;
2099
2100     sv_catpvn(dsv,"",0);
2101     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2102
2103   retry:
2104     while (pv < e) {
2105         if (utf8) {
2106             c = utf8_to_uvchr((U8*)pv, &cl);
2107             if (cl == 0) {
2108                 SvCUR(dsv) = dsvcur;
2109                 pv = start;
2110                 utf8 = 0;
2111                 goto retry;
2112             }
2113         }
2114         else
2115             c = (*pv & 255);
2116
2117         switch (c) {
2118         case 0x00:
2119         case 0x01:
2120         case 0x02:
2121         case 0x03:
2122         case 0x04:
2123         case 0x05:
2124         case 0x06:
2125         case 0x07:
2126         case 0x08:
2127         case 0x0b:
2128         case 0x0c:
2129         case 0x0e:
2130         case 0x0f:
2131         case 0x10:
2132         case 0x11:
2133         case 0x12:
2134         case 0x13:
2135         case 0x14:
2136         case 0x15:
2137         case 0x16:
2138         case 0x17:
2139         case 0x18:
2140         case 0x19:
2141         case 0x1a:
2142         case 0x1b:
2143         case 0x1c:
2144         case 0x1d:
2145         case 0x1e:
2146         case 0x1f:
2147         case 0x7f:
2148         case 0x80:
2149         case 0x81:
2150         case 0x82:
2151         case 0x83:
2152         case 0x84:
2153         case 0x86:
2154         case 0x87:
2155         case 0x88:
2156         case 0x89:
2157         case 0x90:
2158         case 0x91:
2159         case 0x92:
2160         case 0x93:
2161         case 0x94:
2162         case 0x95:
2163         case 0x96:
2164         case 0x97:
2165         case 0x98:
2166         case 0x99:
2167         case 0x9a:
2168         case 0x9b:
2169         case 0x9c:
2170         case 0x9d:
2171         case 0x9e:
2172         case 0x9f:
2173             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2174             break;
2175         case '<':
2176             Perl_sv_catpvf(aTHX_ dsv, "&lt;");
2177             break;
2178         case '>':
2179             Perl_sv_catpvf(aTHX_ dsv, "&gt;");
2180             break;
2181         case '&':
2182             Perl_sv_catpvf(aTHX_ dsv, "&amp;");
2183             break;
2184         case '"':
2185             Perl_sv_catpvf(aTHX_ dsv, "&#34;");
2186             break;
2187         default:
2188             if (c < 0xD800) {
2189                 if (c < 32 || c > 127) {
2190                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2191                 }
2192                 else {
2193                     Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2194                 }
2195                 break;
2196             }
2197             if ((c >= 0xD800 && c <= 0xDB7F) ||
2198                 (c >= 0xDC00 && c <= 0xDFFF) ||
2199                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2200                  c > 0x10ffff)
2201                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2202             else
2203                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2204         }
2205
2206         if (utf8)
2207             pv += UTF8SKIP(pv);
2208         else
2209             pv++;
2210     }
2211
2212     return SvPVX(dsv);
2213 }
2214
2215 char *
2216 Perl_sv_xmlpeek(pTHX_ SV *sv)
2217 {
2218     SV *t = sv_newmortal();
2219     STRLEN n_a;
2220     int unref = 0;
2221
2222     sv_utf8_upgrade(t);
2223     sv_setpvn(t, "", 0);
2224     /* retry: */
2225     if (!sv) {
2226         sv_catpv(t, "VOID=\"\"");
2227         goto finish;
2228     }
2229     else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2230         sv_catpv(t, "WILD=\"\"");
2231         goto finish;
2232     }
2233     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2234         if (sv == &PL_sv_undef) {
2235             sv_catpv(t, "SV_UNDEF=\"1\"");
2236             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2237                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2238                 SvREADONLY(sv))
2239                 goto finish;
2240         }
2241         else if (sv == &PL_sv_no) {
2242             sv_catpv(t, "SV_NO=\"1\"");
2243             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2244                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2245                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2246                                   SVp_POK|SVp_NOK)) &&
2247                 SvCUR(sv) == 0 &&
2248                 SvNVX(sv) == 0.0)
2249                 goto finish;
2250         }
2251         else if (sv == &PL_sv_yes) {
2252             sv_catpv(t, "SV_YES=\"1\"");
2253             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2254                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2255                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2256                                   SVp_POK|SVp_NOK)) &&
2257                 SvCUR(sv) == 1 &&
2258                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2259                 SvNVX(sv) == 1.0)
2260                 goto finish;
2261         }
2262         else {
2263             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2264             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2265                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2266                 SvREADONLY(sv))
2267                 goto finish;
2268         }
2269         sv_catpv(t, " XXX=\"\" ");
2270     }
2271     else if (SvREFCNT(sv) == 0) {
2272         sv_catpv(t, " refcnt=\"0\"");
2273         unref++;
2274     }
2275     else if (DEBUG_R_TEST_) {
2276         int is_tmp = 0;
2277         I32 ix;
2278         /* is this SV on the tmps stack? */
2279         for (ix=PL_tmps_ix; ix>=0; ix--) {
2280             if (PL_tmps_stack[ix] == sv) {
2281                 is_tmp = 1;
2282                 break;
2283             }
2284         }
2285         if (SvREFCNT(sv) > 1)
2286             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2287                     is_tmp ? "T" : "");
2288         else if (is_tmp)
2289             sv_catpv(t, " DRT=\"<T>\"");
2290     }
2291
2292     if (SvROK(sv)) {
2293         sv_catpv(t, " ROK=\"\"");
2294     }
2295     switch (SvTYPE(sv)) {
2296     default:
2297         sv_catpv(t, " FREED=\"1\"");
2298         goto finish;
2299
2300     case SVt_NULL:
2301         sv_catpv(t, " UNDEF=\"1\"");
2302         goto finish;
2303     case SVt_IV:
2304         sv_catpv(t, " IV=\"");
2305         break;
2306     case SVt_NV:
2307         sv_catpv(t, " NV=\"");
2308         break;
2309     case SVt_RV:
2310         sv_catpv(t, " RV=\"");
2311         break;
2312     case SVt_PV:
2313         sv_catpv(t, " PV=\"");
2314         break;
2315     case SVt_PVIV:
2316         sv_catpv(t, " PVIV=\"");
2317         break;
2318     case SVt_PVNV:
2319         sv_catpv(t, " PVNV=\"");
2320         break;
2321     case SVt_PVMG:
2322         sv_catpv(t, " PVMG=\"");
2323         break;
2324     case SVt_PVLV:
2325         sv_catpv(t, " PVLV=\"");
2326         break;
2327     case SVt_PVAV:
2328         sv_catpv(t, " AV=\"");
2329         break;
2330     case SVt_PVHV:
2331         sv_catpv(t, " HV=\"");
2332         break;
2333     case SVt_PVCV:
2334         if (CvGV(sv))
2335             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2336         else
2337             sv_catpv(t, " CV=\"()\"");
2338         goto finish;
2339     case SVt_PVGV:
2340         sv_catpv(t, " GV=\"");
2341         break;
2342     case SVt_BIND:
2343         sv_catpv(t, " BIND=\"");
2344         break;
2345     case SVt_PVFM:
2346         sv_catpv(t, " FM=\"");
2347         break;
2348     case SVt_PVIO:
2349         sv_catpv(t, " IO=\"");
2350         break;
2351     }
2352
2353     if (SvPOKp(sv)) {
2354         if (SvPVX(sv)) {
2355             sv_catxmlsv(t, sv);
2356         }
2357     }
2358     else if (SvNOKp(sv)) {
2359         STORE_NUMERIC_LOCAL_SET_STANDARD();
2360         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2361         RESTORE_NUMERIC_LOCAL();
2362     }
2363     else if (SvIOKp(sv)) {
2364         if (SvIsUV(sv))
2365             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2366         else
2367             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2368     }
2369     else
2370         sv_catpv(t, "");
2371     sv_catpv(t, "\"");
2372
2373   finish:
2374     if (unref) {
2375         while (unref--)
2376             sv_catpv(t, ")");
2377     }
2378     return SvPV(t, n_a);
2379 }
2380
2381 void
2382 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2383 {
2384     if (!pm) {
2385         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2386         return;
2387     }
2388     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2389     level++;
2390     if (PM_GETRE(pm)) {
2391         char *s = PM_GETRE(pm)->precomp;
2392         SV *tmpsv = newSV(0);
2393         SvUTF8_on(tmpsv);
2394         sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2395         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2396              SvPVX(tmpsv));
2397         SvREFCNT_dec(tmpsv);
2398         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2399              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2400     }
2401     else
2402         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2403     if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2404         SV * const tmpsv = pm_description(pm);
2405         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2406         SvREFCNT_dec(tmpsv);
2407     }
2408
2409     level--;
2410     if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
2411         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2412         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2413         do_op_xmldump(level+2, file, pm->op_pmreplroot);
2414         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2415         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2416     }
2417     else
2418         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2419 }
2420
2421 void
2422 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2423 {
2424     do_pmop_xmldump(0, PL_xmlfp, pm);
2425 }
2426
2427 void
2428 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2429 {
2430     UV      seq;
2431     int     contents = 0;
2432     if (!o)
2433         return;
2434     sequence(o);
2435     seq = sequence_num(o);
2436     Perl_xmldump_indent(aTHX_ level, file,
2437         "<op_%s seq=\"%"UVuf" -> ",
2438              OP_NAME(o),
2439                       seq);
2440     level++;
2441     if (o->op_next)
2442         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2443                       sequence_num(o->op_next));
2444     else
2445         PerlIO_printf(file, "DONE\"");
2446
2447     if (o->op_targ) {
2448         if (o->op_type == OP_NULL)
2449         {
2450             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2451             if (o->op_targ == OP_NEXTSTATE)
2452             {
2453                 if (CopLINE(cCOPo))
2454                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2455                                      (UV)CopLINE(cCOPo));
2456                 if (CopSTASHPV(cCOPo))
2457                     PerlIO_printf(file, " package=\"%s\"",
2458                                      CopSTASHPV(cCOPo));
2459                 if (cCOPo->cop_label)
2460                     PerlIO_printf(file, " label=\"%s\"",
2461                                      cCOPo->cop_label);
2462             }
2463         }
2464         else
2465             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2466     }
2467 #ifdef DUMPADDR
2468     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2469 #endif
2470     if (o->op_flags) {
2471         SV *tmpsv = newSVpvn("", 0);
2472         switch (o->op_flags & OPf_WANT) {
2473         case OPf_WANT_VOID:
2474             sv_catpv(tmpsv, ",VOID");
2475             break;
2476         case OPf_WANT_SCALAR:
2477             sv_catpv(tmpsv, ",SCALAR");
2478             break;
2479         case OPf_WANT_LIST:
2480             sv_catpv(tmpsv, ",LIST");
2481             break;
2482         default:
2483             sv_catpv(tmpsv, ",UNKNOWN");
2484             break;
2485         }
2486         if (o->op_flags & OPf_KIDS)
2487             sv_catpv(tmpsv, ",KIDS");
2488         if (o->op_flags & OPf_PARENS)
2489             sv_catpv(tmpsv, ",PARENS");
2490         if (o->op_flags & OPf_STACKED)
2491             sv_catpv(tmpsv, ",STACKED");
2492         if (o->op_flags & OPf_REF)
2493             sv_catpv(tmpsv, ",REF");
2494         if (o->op_flags & OPf_MOD)
2495             sv_catpv(tmpsv, ",MOD");
2496         if (o->op_flags & OPf_SPECIAL)
2497             sv_catpv(tmpsv, ",SPECIAL");
2498         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2499         SvREFCNT_dec(tmpsv);
2500     }
2501     if (o->op_private) {
2502         SV *tmpsv = newSVpvn("", 0);
2503         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2504             if (o->op_private & OPpTARGET_MY)
2505                 sv_catpv(tmpsv, ",TARGET_MY");
2506         }
2507         else if (o->op_type == OP_LEAVESUB ||
2508                  o->op_type == OP_LEAVE ||
2509                  o->op_type == OP_LEAVESUBLV ||
2510                  o->op_type == OP_LEAVEWRITE) {
2511             if (o->op_private & OPpREFCOUNTED)
2512                 sv_catpv(tmpsv, ",REFCOUNTED");
2513         }
2514         else if (o->op_type == OP_AASSIGN) {
2515             if (o->op_private & OPpASSIGN_COMMON)
2516                 sv_catpv(tmpsv, ",COMMON");
2517         }
2518         else if (o->op_type == OP_SASSIGN) {
2519             if (o->op_private & OPpASSIGN_BACKWARDS)
2520                 sv_catpv(tmpsv, ",BACKWARDS");
2521         }
2522         else if (o->op_type == OP_TRANS) {
2523             if (o->op_private & OPpTRANS_SQUASH)
2524                 sv_catpv(tmpsv, ",SQUASH");
2525             if (o->op_private & OPpTRANS_DELETE)
2526                 sv_catpv(tmpsv, ",DELETE");
2527             if (o->op_private & OPpTRANS_COMPLEMENT)
2528                 sv_catpv(tmpsv, ",COMPLEMENT");
2529             if (o->op_private & OPpTRANS_IDENTICAL)
2530                 sv_catpv(tmpsv, ",IDENTICAL");
2531             if (o->op_private & OPpTRANS_GROWS)
2532                 sv_catpv(tmpsv, ",GROWS");
2533         }
2534         else if (o->op_type == OP_REPEAT) {
2535             if (o->op_private & OPpREPEAT_DOLIST)
2536                 sv_catpv(tmpsv, ",DOLIST");
2537         }
2538         else if (o->op_type == OP_ENTERSUB ||
2539                  o->op_type == OP_RV2SV ||
2540                  o->op_type == OP_GVSV ||
2541                  o->op_type == OP_RV2AV ||
2542                  o->op_type == OP_RV2HV ||
2543                  o->op_type == OP_RV2GV ||
2544                  o->op_type == OP_AELEM ||
2545                  o->op_type == OP_HELEM )
2546         {
2547             if (o->op_type == OP_ENTERSUB) {
2548                 if (o->op_private & OPpENTERSUB_AMPER)
2549                     sv_catpv(tmpsv, ",AMPER");
2550                 if (o->op_private & OPpENTERSUB_DB)
2551                     sv_catpv(tmpsv, ",DB");
2552                 if (o->op_private & OPpENTERSUB_HASTARG)
2553                     sv_catpv(tmpsv, ",HASTARG");
2554                 if (o->op_private & OPpENTERSUB_NOPAREN)
2555                     sv_catpv(tmpsv, ",NOPAREN");
2556                 if (o->op_private & OPpENTERSUB_INARGS)
2557                     sv_catpv(tmpsv, ",INARGS");
2558                 if (o->op_private & OPpENTERSUB_NOMOD)
2559                     sv_catpv(tmpsv, ",NOMOD");
2560             }
2561             else {
2562                 switch (o->op_private & OPpDEREF) {
2563             case OPpDEREF_SV:
2564                 sv_catpv(tmpsv, ",SV");
2565                 break;
2566             case OPpDEREF_AV:
2567                 sv_catpv(tmpsv, ",AV");
2568                 break;
2569             case OPpDEREF_HV:
2570                 sv_catpv(tmpsv, ",HV");
2571                 break;
2572             }
2573                 if (o->op_private & OPpMAYBE_LVSUB)
2574                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2575             }
2576             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2577                 if (o->op_private & OPpLVAL_DEFER)
2578                     sv_catpv(tmpsv, ",LVAL_DEFER");
2579             }
2580             else {
2581                 if (o->op_private & HINT_STRICT_REFS)
2582                     sv_catpv(tmpsv, ",STRICT_REFS");
2583                 if (o->op_private & OPpOUR_INTRO)
2584                     sv_catpv(tmpsv, ",OUR_INTRO");
2585             }
2586         }
2587         else if (o->op_type == OP_CONST) {
2588             if (o->op_private & OPpCONST_BARE)
2589                 sv_catpv(tmpsv, ",BARE");
2590             if (o->op_private & OPpCONST_STRICT)
2591                 sv_catpv(tmpsv, ",STRICT");
2592             if (o->op_private & OPpCONST_ARYBASE)
2593                 sv_catpv(tmpsv, ",ARYBASE");
2594             if (o->op_private & OPpCONST_WARNING)
2595                 sv_catpv(tmpsv, ",WARNING");
2596             if (o->op_private & OPpCONST_ENTERED)
2597                 sv_catpv(tmpsv, ",ENTERED");
2598         }
2599         else if (o->op_type == OP_FLIP) {
2600             if (o->op_private & OPpFLIP_LINENUM)
2601                 sv_catpv(tmpsv, ",LINENUM");
2602         }
2603         else if (o->op_type == OP_FLOP) {
2604             if (o->op_private & OPpFLIP_LINENUM)
2605                 sv_catpv(tmpsv, ",LINENUM");
2606         }
2607         else if (o->op_type == OP_RV2CV) {
2608             if (o->op_private & OPpLVAL_INTRO)
2609                 sv_catpv(tmpsv, ",INTRO");
2610         }
2611         else if (o->op_type == OP_GV) {
2612             if (o->op_private & OPpEARLY_CV)
2613                 sv_catpv(tmpsv, ",EARLY_CV");
2614         }
2615         else if (o->op_type == OP_LIST) {
2616             if (o->op_private & OPpLIST_GUESSED)
2617                 sv_catpv(tmpsv, ",GUESSED");
2618         }
2619         else if (o->op_type == OP_DELETE) {
2620             if (o->op_private & OPpSLICE)
2621                 sv_catpv(tmpsv, ",SLICE");
2622         }
2623         else if (o->op_type == OP_EXISTS) {
2624             if (o->op_private & OPpEXISTS_SUB)
2625                 sv_catpv(tmpsv, ",EXISTS_SUB");
2626         }
2627         else if (o->op_type == OP_SORT) {
2628             if (o->op_private & OPpSORT_NUMERIC)
2629                 sv_catpv(tmpsv, ",NUMERIC");
2630             if (o->op_private & OPpSORT_INTEGER)
2631                 sv_catpv(tmpsv, ",INTEGER");
2632             if (o->op_private & OPpSORT_REVERSE)
2633                 sv_catpv(tmpsv, ",REVERSE");
2634         }
2635         else if (o->op_type == OP_THREADSV) {
2636             if (o->op_private & OPpDONE_SVREF)
2637                 sv_catpv(tmpsv, ",SVREF");
2638         }
2639         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2640             if (o->op_private & OPpOPEN_IN_RAW)
2641                 sv_catpv(tmpsv, ",IN_RAW");
2642             if (o->op_private & OPpOPEN_IN_CRLF)
2643                 sv_catpv(tmpsv, ",IN_CRLF");
2644             if (o->op_private & OPpOPEN_OUT_RAW)
2645                 sv_catpv(tmpsv, ",OUT_RAW");
2646             if (o->op_private & OPpOPEN_OUT_CRLF)
2647                 sv_catpv(tmpsv, ",OUT_CRLF");
2648         }
2649         else if (o->op_type == OP_EXIT) {
2650             if (o->op_private & OPpEXIT_VMSISH)
2651                 sv_catpv(tmpsv, ",EXIT_VMSISH");
2652             if (o->op_private & OPpHUSH_VMSISH)
2653                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2654         }
2655         else if (o->op_type == OP_DIE) {
2656             if (o->op_private & OPpHUSH_VMSISH)
2657                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2658         }
2659         else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2660             if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2661                 sv_catpv(tmpsv, ",FT_ACCESS");
2662             if (o->op_private & OPpFT_STACKED)
2663                 sv_catpv(tmpsv, ",FT_STACKED");
2664         }
2665         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2666             sv_catpv(tmpsv, ",INTRO");
2667         if (SvCUR(tmpsv))
2668             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2669         SvREFCNT_dec(tmpsv);
2670     }
2671
2672     switch (o->op_type) {
2673     case OP_AELEMFAST:
2674         if (o->op_flags & OPf_SPECIAL) {
2675             break;
2676         }
2677     case OP_GVSV:
2678     case OP_GV:
2679 #ifdef USE_ITHREADS
2680         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2681 #else
2682         if (cSVOPo->op_sv) {
2683             SV *tmpsv1 = newSV(0);
2684             SV *tmpsv2 = newSV(0);
2685             char *s;
2686             STRLEN len;
2687             SvUTF8_on(tmpsv1);
2688             SvUTF8_on(tmpsv2);
2689             ENTER;
2690             SAVEFREESV(tmpsv1);
2691             SAVEFREESV(tmpsv2);
2692             gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2693             s = SvPV(tmpsv1,len);
2694             sv_catxmlpvn(tmpsv2, s, len, 1);
2695             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2696             LEAVE;
2697         }
2698         else
2699             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2700 #endif
2701         break;
2702     case OP_CONST:
2703     case OP_METHOD_NAMED:
2704 #ifndef USE_ITHREADS
2705         /* with ITHREADS, consts are stored in the pad, and the right pad
2706          * may not be active here, so skip */
2707         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2708 #endif
2709         break;
2710     case OP_ANONCODE:
2711         if (!contents) {
2712             contents = 1;
2713             PerlIO_printf(file, ">\n");
2714         }
2715         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2716         break;
2717     case OP_SETSTATE:
2718     case OP_NEXTSTATE:
2719     case OP_DBSTATE:
2720         if (CopLINE(cCOPo))
2721             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2722                              (UV)CopLINE(cCOPo));
2723         if (CopSTASHPV(cCOPo))
2724             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2725                              CopSTASHPV(cCOPo));
2726         if (cCOPo->cop_label)
2727             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2728                              cCOPo->cop_label);
2729         break;
2730     case OP_ENTERLOOP:
2731         S_xmldump_attr(aTHX_ level, file, "redo=\"");
2732         if (cLOOPo->op_redoop)
2733             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2734         else
2735             PerlIO_printf(file, "DONE\"");
2736         S_xmldump_attr(aTHX_ level, file, "next=\"");
2737         if (cLOOPo->op_nextop)
2738             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2739         else
2740             PerlIO_printf(file, "DONE\"");
2741         S_xmldump_attr(aTHX_ level, file, "last=\"");
2742         if (cLOOPo->op_lastop)
2743             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2744         else
2745             PerlIO_printf(file, "DONE\"");
2746         break;
2747     case OP_COND_EXPR:
2748     case OP_RANGE:
2749     case OP_MAPWHILE:
2750     case OP_GREPWHILE:
2751     case OP_OR:
2752     case OP_AND:
2753         S_xmldump_attr(aTHX_ level, file, "other=\"");
2754         if (cLOGOPo->op_other)
2755             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2756         else
2757             PerlIO_printf(file, "DONE\"");
2758         break;
2759     case OP_LEAVE:
2760     case OP_LEAVEEVAL:
2761     case OP_LEAVESUB:
2762     case OP_LEAVESUBLV:
2763     case OP_LEAVEWRITE:
2764     case OP_SCOPE:
2765         if (o->op_private & OPpREFCOUNTED)
2766             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2767         break;
2768     default:
2769         break;
2770     }
2771
2772     if (PL_madskills && o->op_madprop) {
2773         SV *tmpsv = newSVpvn("", 0);
2774         MADPROP* mp = o->op_madprop;
2775         sv_utf8_upgrade(tmpsv);
2776         if (!contents) {
2777             contents = 1;
2778             PerlIO_printf(file, ">\n");
2779         }
2780         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2781         level++;
2782         while (mp) {
2783             char tmp = mp->mad_key;
2784             sv_setpvn(tmpsv,"\"",1);
2785             if (tmp)
2786                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2787             sv_catpv(tmpsv, "\"");
2788             switch (mp->mad_type) {
2789             case MAD_NULL:
2790                 sv_catpv(tmpsv, "NULL");
2791                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2792                 break;
2793             case MAD_PV:
2794                 sv_catpv(tmpsv, " val=\"");
2795                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2796                 sv_catpv(tmpsv, "\"");
2797                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2798                 break;
2799             case MAD_SV:
2800                 sv_catpv(tmpsv, " val=\"");
2801                 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2802                 sv_catpv(tmpsv, "\"");
2803                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2804                 break;
2805             case MAD_OP:
2806                 if ((OP*)mp->mad_val) {
2807                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2808                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2809                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2810                 }
2811                 break;
2812             default:
2813                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2814                 break;
2815             }
2816             mp = mp->mad_next;
2817         }
2818         level--;
2819         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2820
2821         SvREFCNT_dec(tmpsv);
2822     }
2823
2824     switch (o->op_type) {
2825     case OP_PUSHRE:
2826     case OP_MATCH:
2827     case OP_QR:
2828     case OP_SUBST:
2829         if (!contents) {
2830             contents = 1;
2831             PerlIO_printf(file, ">\n");
2832         }
2833         do_pmop_xmldump(level, file, cPMOPo);
2834         break;
2835     default:
2836         break;
2837     }
2838
2839     if (o->op_flags & OPf_KIDS) {
2840         OP *kid;
2841         if (!contents) {
2842             contents = 1;
2843             PerlIO_printf(file, ">\n");
2844         }
2845         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2846             do_op_xmldump(level, file, kid);
2847     }
2848
2849     if (contents)
2850         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2851     else
2852         PerlIO_printf(file, " />\n");
2853 }
2854
2855 void
2856 Perl_op_xmldump(pTHX_ const OP *o)
2857 {
2858     do_op_xmldump(0, PL_xmlfp, o);
2859 }
2860 #endif
2861
2862 /*
2863  * Local variables:
2864  * c-indentation-style: bsd
2865  * c-basic-offset: 4
2866  * indent-tabs-mode: t
2867  * End:
2868  *
2869  * ex: set ts=8 sts=4 sw=4 noet:
2870  */