dump.c

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