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