dump.c

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