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     if (flags & SVf_BREAK)      sv_catpv(d, "BREAK,");
1394
1395     if (flags & SVf_AMAGIC)     sv_catpv(d, "OVERLOAD,");
1396     if (flags & SVp_IOK)        sv_catpv(d, "pIOK,");
1397     if (flags & SVp_NOK)        sv_catpv(d, "pNOK,");
1398     if (flags & SVp_POK)        sv_catpv(d, "pPOK,");
1399     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1400         if (SvPCS_IMPORTED(sv))
1401                                 sv_catpv(d, "PCS_IMPORTED,");
1402         else
1403                                 sv_catpv(d, "SCREAM,");
1404     }
1405
1406     switch (type) {
1407     case SVt_PVCV:
1408     case SVt_PVFM:
1409         if (CvANON(sv))         sv_catpv(d, "ANON,");
1410         if (CvUNIQUE(sv))       sv_catpv(d, "UNIQUE,");
1411         if (CvCLONE(sv))        sv_catpv(d, "CLONE,");
1412         if (CvCLONED(sv))       sv_catpv(d, "CLONED,");
1413         if (CvCONST(sv))        sv_catpv(d, "CONST,");
1414         if (CvNODEBUG(sv))      sv_catpv(d, "NODEBUG,");
1415         if (SvCOMPILED(sv))     sv_catpv(d, "COMPILED,");
1416         if (CvLVALUE(sv))       sv_catpv(d, "LVALUE,");
1417         if (CvMETHOD(sv))       sv_catpv(d, "METHOD,");
1418         if (CvLOCKED(sv))       sv_catpv(d, "LOCKED,");
1419         if (CvWEAKOUTSIDE(sv))  sv_catpv(d, "WEAKOUTSIDE,");
1420         if (CvASSERTION(sv))    sv_catpv(d, "ASSERTION,");
1421         break;
1422     case SVt_PVHV:
1423         if (HvSHAREKEYS(sv))    sv_catpv(d, "SHAREKEYS,");
1424         if (HvLAZYDEL(sv))      sv_catpv(d, "LAZYDEL,");
1425         if (HvHASKFLAGS(sv))    sv_catpv(d, "HASKFLAGS,");
1426         if (HvREHASH(sv))       sv_catpv(d, "REHASH,");
1427         if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1428         break;
1429     case SVt_PVGV:
1430     case SVt_PVLV:
1431         if (isGV_with_GP(sv)) {
1432             if (GvINTRO(sv))    sv_catpv(d, "INTRO,");
1433             if (GvMULTI(sv))    sv_catpv(d, "MULTI,");
1434             if (GvUNIQUE(sv))   sv_catpv(d, "UNIQUE,");
1435             if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1436             if (GvIN_PAD(sv))   sv_catpv(d, "IN_PAD,");
1437         }
1438         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1439             sv_catpv(d, "IMPORT");
1440             if (GvIMPORTED(sv) == GVf_IMPORTED)
1441                 sv_catpv(d, "ALL,");
1442             else {
1443                 sv_catpv(d, "(");
1444                 if (GvIMPORTED_SV(sv))  sv_catpv(d, " SV");
1445                 if (GvIMPORTED_AV(sv))  sv_catpv(d, " AV");
1446                 if (GvIMPORTED_HV(sv))  sv_catpv(d, " HV");
1447                 if (GvIMPORTED_CV(sv))  sv_catpv(d, " CV");
1448                 sv_catpv(d, " ),");
1449             }
1450         }
1451         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1452         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1453         /* FALL THROUGH */
1454     default:
1455     evaled_or_uv:
1456         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1457         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1458         break;
1459     case SVt_PVMG:
1460         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1461         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1462         /* FALL THROUGH */
1463     case SVt_PVNV:
1464         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1465         goto evaled_or_uv;
1466     case SVt_PVAV:
1467         break;
1468     }
1469     /* SVphv_SHAREKEYS is also 0x20000000 */
1470     if ((type != SVt_PVHV) && SvUTF8(sv))
1471         sv_catpv(d, "UTF8");
1472
1473     if (*(SvEND(d) - 1) == ',') {
1474         SvCUR_set(d, SvCUR(d) - 1);
1475         SvPVX(d)[SvCUR(d)] = '\0';
1476     }
1477     sv_catpv(d, ")");
1478     s = SvPVX_const(d);
1479
1480 #ifdef DEBUG_LEAKING_SCALARS
1481     Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1482         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1483         sv->sv_debug_line,
1484         sv->sv_debug_inpad ? "for" : "by",
1485         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1486         sv->sv_debug_cloned ? " (cloned)" : "");
1487 #endif
1488     Perl_dump_indent(aTHX_ level, file, "SV = ");
1489     if (type < SVt_LAST) {
1490         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1491
1492         if (type ==  SVt_NULL) {
1493             SvREFCNT_dec(d);
1494             return;
1495         }
1496     } else {
1497         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1498         SvREFCNT_dec(d);
1499         return;
1500     }
1501     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1502          && type != SVt_PVCV && !isGV_with_GP(sv))
1503         || type == SVt_IV) {
1504         if (SvIsUV(sv)
1505 #ifdef PERL_OLD_COPY_ON_WRITE
1506                        || SvIsCOW(sv)
1507 #endif
1508                                      )
1509             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1510         else
1511             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1512         if (SvOOK(sv))
1513             PerlIO_printf(file, "  (OFFSET)");
1514 #ifdef PERL_OLD_COPY_ON_WRITE
1515         if (SvIsCOW_shared_hash(sv))
1516             PerlIO_printf(file, "  (HASH)");
1517         else if (SvIsCOW_normal(sv))
1518             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1519 #endif
1520         PerlIO_putc(file, '\n');
1521     }
1522     if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1523         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1524                          (UV) COP_SEQ_RANGE_LOW(sv));
1525         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1526                          (UV) COP_SEQ_RANGE_HIGH(sv));
1527     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1528                 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv)
1529                 && !SvVALID(sv))
1530                || type == SVt_NV) {
1531         STORE_NUMERIC_LOCAL_SET_STANDARD();
1532         /* %Vg doesn't work? --jhi */
1533 #ifdef USE_LONG_DOUBLE
1534         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1535 #else
1536         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1537 #endif
1538         RESTORE_NUMERIC_LOCAL();
1539     }
1540     if (SvROK(sv)) {
1541         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1542         if (nest < maxnest)
1543             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1544     }
1545     if (type < SVt_PV) {
1546         SvREFCNT_dec(d);
1547         return;
1548     }
1549     if (type <= SVt_PVLV && !isGV_with_GP(sv)) {
1550         if (SvPVX_const(sv)) {
1551             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1552             if (SvOOK(sv))
1553                 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1554             PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1555             if (SvUTF8(sv)) /* the 8?  \x{....} */
1556                 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1557             PerlIO_printf(file, "\n");
1558             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1559             Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
1560         }
1561         else
1562             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1563     }
1564     if (type >= SVt_PVMG) {
1565         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1566             HV *ost = SvOURSTASH(sv);
1567             if (ost)
1568                 do_hv_dump(level, file, "  OURSTASH", ost);
1569         } else {
1570             if (SvMAGIC(sv))
1571                 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1572         }
1573         if (SvSTASH(sv))
1574             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1575     }
1576     switch (type) {
1577     case SVt_PVAV:
1578         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1579         if (AvARRAY(sv) != AvALLOC(sv)) {
1580             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1581             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1582         }
1583         else
1584             PerlIO_putc(file, '\n');
1585         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1586         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1587         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1588         sv_setpvn(d, "", 0);
1589         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1590         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1591         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1592                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1593         if (nest < maxnest && av_len((AV*)sv) >= 0) {
1594             int count;
1595             for (count = 0; count <=  av_len((AV*)sv) && count < maxnest; count++) {
1596                 SV** elt = av_fetch((AV*)sv,count,0);
1597
1598                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1599                 if (elt)
1600                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1601             }
1602         }
1603         break;
1604     case SVt_PVHV:
1605         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1606         if (HvARRAY(sv) && HvKEYS(sv)) {
1607             /* Show distribution of HEs in the ARRAY */
1608             int freq[200];
1609 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1610             int i;
1611             int max = 0;
1612             U32 pow2 = 2, keys = HvKEYS(sv);
1613             NV theoret, sum = 0;
1614
1615             PerlIO_printf(file, "  (");
1616             Zero(freq, FREQ_MAX + 1, int);
1617             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1618                 HE* h;
1619                 int count = 0;
1620                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1621                     count++;
1622                 if (count > FREQ_MAX)
1623                     count = FREQ_MAX;
1624                 freq[count]++;
1625                 if (max < count)
1626                     max = count;
1627             }
1628             for (i = 0; i <= max; i++) {
1629                 if (freq[i]) {
1630                     PerlIO_printf(file, "%d%s:%d", i,
1631                                   (i == FREQ_MAX) ? "+" : "",
1632                                   freq[i]);
1633                     if (i != max)
1634                         PerlIO_printf(file, ", ");
1635                 }
1636             }
1637             PerlIO_putc(file, ')');
1638             /* The "quality" of a hash is defined as the total number of
1639                comparisons needed to access every element once, relative
1640                to the expected number needed for a random hash.
1641
1642                The total number of comparisons is equal to the sum of
1643                the squares of the number of entries in each bucket.
1644                For a random hash of n keys into k buckets, the expected
1645                value is
1646                                 n + n(n-1)/2k
1647             */
1648
1649             for (i = max; i > 0; i--) { /* Precision: count down. */
1650                 sum += freq[i] * i * i;
1651             }
1652             while ((keys = keys >> 1))
1653                 pow2 = pow2 << 1;
1654             theoret = HvKEYS(sv);
1655             theoret += theoret * (theoret-1)/pow2;
1656             PerlIO_putc(file, '\n');
1657             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1658         }
1659         PerlIO_putc(file, '\n');
1660         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1661         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1662         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1663         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1664         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1665         {
1666             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1667             if (mg && mg->mg_obj) {
1668                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1669             }
1670         }
1671         {
1672             const char * const hvname = HvNAME_get(sv);
1673             if (hvname)
1674                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1675         }
1676         if (SvOOK(sv)) {
1677             const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1678             if (backrefs) {
1679                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1680                                  PTR2UV(backrefs));
1681                 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1682                            dumpops, pvlim);
1683             }
1684         }
1685         if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1686             HE *he;
1687             HV * const hv = (HV*)sv;
1688             int count = maxnest - nest;
1689
1690             hv_iterinit(hv);
1691             while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1692                    && count--) {
1693                 SV *elt, *keysv;
1694                 const char *keypv;
1695                 STRLEN len;
1696                 const U32 hash = HeHASH(he);
1697
1698                 keysv = hv_iterkeysv(he);
1699                 keypv = SvPV_const(keysv, len);
1700                 elt = hv_iterval(hv, he);
1701                 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1702                 if (SvUTF8(keysv))
1703                     PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1704                 if (HeKREHASH(he))
1705                     PerlIO_printf(file, "[REHASH] ");
1706                 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1707                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1708             }
1709             hv_iterinit(hv);            /* Return to status quo */
1710         }
1711         break;
1712     case SVt_PVCV:
1713         if (SvPOK(sv)) {
1714             STRLEN len;
1715             const char *const proto =  SvPV_const(sv, len);
1716             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1717                              (int) len, proto);
1718         }
1719         /* FALL THROUGH */
1720     case SVt_PVFM:
1721         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1722         if (!CvISXSUB(sv)) {
1723             if (CvSTART(sv)) {
1724                 Perl_dump_indent(aTHX_ level, file,
1725                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1726                                  PTR2UV(CvSTART(sv)),
1727                                  (IV)sequence_num(CvSTART(sv)));
1728             }
1729             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1730                              PTR2UV(CvROOT(sv)));
1731             if (CvROOT(sv) && dumpops) {
1732                 do_op_dump(level+1, file, CvROOT(sv));
1733             }
1734         } else {
1735             SV *constant = cv_const_sv((CV *)sv);
1736
1737             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1738
1739             if (constant) {
1740                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1741                                  " (CONST SV)\n",
1742                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1743                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1744                            pvlim);
1745             } else {
1746                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1747                                  (IV)CvXSUBANY(sv).any_i32);
1748             }
1749         }
1750         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1751         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1752         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1753         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1754         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1755         if (type == SVt_PVFM)
1756             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
1757         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1758         if (nest < maxnest) {
1759             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1760         }
1761         {
1762             const CV * const outside = CvOUTSIDE(sv);
1763             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1764                         PTR2UV(outside),
1765                         (!outside ? "null"
1766                          : CvANON(outside) ? "ANON"
1767                          : (outside == PL_main_cv) ? "MAIN"
1768                          : CvUNIQUE(outside) ? "UNIQUE"
1769                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1770         }
1771         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1772             do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1773         break;
1774     case SVt_PVGV:
1775     case SVt_PVLV:
1776         if (type == SVt_PVLV) {
1777             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
1778             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1779             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1780             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1781             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1782                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1783                     dumpops, pvlim);
1784         }
1785         if (SvVALID(sv)) {
1786             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %u\n", (U8)BmFLAGS(sv));
1787             Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
1788             Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1789             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1790         }
1791         if (!isGV_with_GP(sv))
1792             break;
1793         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
1794         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1795         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
1796         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1797         if (!GvGP(sv))
1798             break;
1799         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1800         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1801         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1802         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
1803         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1804         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1805         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1806         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1807         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
1808         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
1809         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1810         do_gv_dump (level, file, "    EGV", GvEGV(sv));
1811         break;
1812     case SVt_PVIO:
1813         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1814         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1815         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1816         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
1817         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1818         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1819         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1820         if (IoTOP_NAME(sv))
1821             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1822         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1823             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
1824         else {
1825             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
1826                              PTR2UV(IoTOP_GV(sv)));
1827             do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1828                         dumpops, pvlim);
1829         }
1830         /* Source filters hide things that are not GVs in these three, so let's
1831            be careful out there.  */
1832         if (IoFMT_NAME(sv))
1833             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1834         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1835             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
1836         else {
1837             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
1838                              PTR2UV(IoFMT_GV(sv)));
1839             do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1840                         dumpops, pvlim);
1841         }
1842         if (IoBOTTOM_NAME(sv))
1843             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1844         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1845             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
1846         else {
1847             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
1848                              PTR2UV(IoBOTTOM_GV(sv)));
1849             do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1850                         dumpops, pvlim);
1851         }
1852         Perl_dump_indent(aTHX_ level, file, "  SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1853         if (isPRINT(IoTYPE(sv)))
1854             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
1855         else
1856             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
1857         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1858         break;
1859     }
1860     SvREFCNT_dec(d);
1861 }
1862
1863 void
1864 Perl_sv_dump(pTHX_ SV *sv)
1865 {
1866     dVAR;
1867     do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1868 }
1869
1870 int
1871 Perl_runops_debug(pTHX)
1872 {
1873     dVAR;
1874     if (!PL_op) {
1875         if (ckWARN_d(WARN_DEBUGGING))
1876             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1877         return 0;
1878     }
1879
1880     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1881     do {
1882         PERL_ASYNC_CHECK();
1883         if (PL_debug) {
1884             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1885                 PerlIO_printf(Perl_debug_log,
1886                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1887                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1888                               PTR2UV(*PL_watchaddr));
1889             if (DEBUG_s_TEST_) {
1890                 if (DEBUG_v_TEST_) {
1891                     PerlIO_printf(Perl_debug_log, "\n");
1892                     deb_stack_all();
1893                 }
1894                 else
1895                     debstack();
1896             }
1897
1898
1899             if (DEBUG_t_TEST_) debop(PL_op);
1900             if (DEBUG_P_TEST_) debprof(PL_op);
1901         }
1902     } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1903     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1904
1905     TAINT_NOT;
1906     return 0;
1907 }
1908
1909 I32
1910 Perl_debop(pTHX_ const OP *o)
1911 {
1912     dVAR;
1913     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1914         return 0;
1915
1916     Perl_deb(aTHX_ "%s", OP_NAME(o));
1917     switch (o->op_type) {
1918     case OP_CONST:
1919         PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1920         break;
1921     case OP_GVSV:
1922     case OP_GV:
1923         if (cGVOPo_gv) {
1924             SV * const sv = newSV(0);
1925 #ifdef PERL_MAD
1926             /* FIXME - it this making unwarranted assumptions about the
1927                UTF-8 cleanliness of the dump file handle?  */
1928             SvUTF8_on(sv);
1929 #endif
1930             gv_fullname3(sv, cGVOPo_gv, NULL);
1931             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1932             SvREFCNT_dec(sv);
1933         }
1934         else
1935             PerlIO_printf(Perl_debug_log, "(NULL)");
1936         break;
1937     case OP_PADSV:
1938     case OP_PADAV:
1939     case OP_PADHV:
1940         {
1941         /* print the lexical's name */
1942         CV * const cv = deb_curcv(cxstack_ix);
1943         SV *sv;
1944         if (cv) {
1945             AV * const padlist = CvPADLIST(cv);
1946             AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1947             sv = *av_fetch(comppad, o->op_targ, FALSE);
1948         } else
1949             sv = NULL;
1950         if (sv)
1951             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1952         else
1953             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1954         }
1955         break;
1956     default:
1957         break;
1958     }
1959     PerlIO_printf(Perl_debug_log, "\n");
1960     return 0;
1961 }
1962
1963 STATIC CV*
1964 S_deb_curcv(pTHX_ I32 ix)
1965 {
1966     dVAR;
1967     const PERL_CONTEXT * const cx = &cxstack[ix];
1968     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1969         return cx->blk_sub.cv;
1970     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1971         return PL_compcv;
1972     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1973         return PL_main_cv;
1974     else if (ix <= 0)
1975         return NULL;
1976     else
1977         return deb_curcv(ix - 1);
1978 }
1979
1980 void
1981 Perl_watch(pTHX_ char **addr)
1982 {
1983     dVAR;
1984     PL_watchaddr = addr;
1985     PL_watchok = *addr;
1986     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
1987         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
1988 }
1989
1990 STATIC void
1991 S_debprof(pTHX_ const OP *o)
1992 {
1993     dVAR;
1994     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1995         return;
1996     if (!PL_profiledata)
1997         Newxz(PL_profiledata, MAXO, U32);
1998     ++PL_profiledata[o->op_type];
1999 }
2000
2001 void
2002 Perl_debprofdump(pTHX)
2003 {
2004     dVAR;
2005     unsigned i;
2006     if (!PL_profiledata)
2007         return;
2008     for (i = 0; i < MAXO; i++) {
2009         if (PL_profiledata[i])
2010             PerlIO_printf(Perl_debug_log,
2011                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2012                                        PL_op_name[i]);
2013     }
2014 }
2015
2016 #ifdef PERL_MAD
2017 /*
2018  *    XML variants of most of the above routines
2019  */
2020
2021 STATIC
2022 void
2023 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2024 {
2025     va_list args;
2026     PerlIO_printf(file, "\n    ");
2027     va_start(args, pat);
2028     xmldump_vindent(level, file, pat, &args);
2029     va_end(args);
2030 }
2031
2032
2033 void
2034 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2035 {
2036     va_list args;
2037     va_start(args, pat);
2038     xmldump_vindent(level, file, pat, &args);
2039     va_end(args);
2040 }
2041
2042 void
2043 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2044 {
2045     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2046     PerlIO_vprintf(file, pat, *args);
2047 }
2048
2049 void
2050 Perl_xmldump_all(pTHX)
2051 {
2052     PerlIO_setlinebuf(PL_xmlfp);
2053     if (PL_main_root)
2054         op_xmldump(PL_main_root);
2055     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2056         PerlIO_close(PL_xmlfp);
2057     PL_xmlfp = 0;
2058 }
2059
2060 void
2061 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2062 {
2063     I32 i;
2064     HE  *entry;
2065
2066     if (!HvARRAY(stash))
2067         return;
2068     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2069         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2070             GV *gv = (GV*)HeVAL(entry);
2071             HV *hv;
2072             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2073                 continue;
2074             if (GvCVu(gv))
2075                 xmldump_sub(gv);
2076             if (GvFORM(gv))
2077                 xmldump_form(gv);
2078             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2079                 && (hv = GvHV(gv)) && hv != PL_defstash)
2080                 xmldump_packsubs(hv);           /* nested package */
2081         }
2082     }
2083 }
2084
2085 void
2086 Perl_xmldump_sub(pTHX_ const GV *gv)
2087 {
2088     SV *sv = sv_newmortal();
2089
2090     gv_fullname3(sv, gv, Nullch);
2091     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2092     if (CvXSUB(GvCV(gv)))
2093         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2094             PTR2UV(CvXSUB(GvCV(gv))),
2095             (int)CvXSUBANY(GvCV(gv)).any_i32);
2096     else if (CvROOT(GvCV(gv)))
2097         op_xmldump(CvROOT(GvCV(gv)));
2098     else
2099         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2100 }
2101
2102 void
2103 Perl_xmldump_form(pTHX_ const GV *gv)
2104 {
2105     SV *sv = sv_newmortal();
2106
2107     gv_fullname3(sv, gv, Nullch);
2108     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2109     if (CvROOT(GvFORM(gv)))
2110         op_xmldump(CvROOT(GvFORM(gv)));
2111     else
2112         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2113 }
2114
2115 void
2116 Perl_xmldump_eval(pTHX)
2117 {
2118     op_xmldump(PL_eval_root);
2119 }
2120
2121 char *
2122 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2123 {
2124     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2125 }
2126
2127 char *
2128 Perl_sv_catxmlpvn(pTHX_ SV *dsv, char* pv, STRLEN len, int utf8)
2129 {
2130     unsigned int c;
2131     char *e = pv + len;
2132     char *start = pv;
2133     STRLEN dsvcur;
2134     STRLEN cl;
2135
2136     sv_catpvn(dsv,"",0);
2137     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2138
2139   retry:
2140     while (pv < e) {
2141         if (utf8) {
2142             c = utf8_to_uvchr((U8*)pv, &cl);
2143             if (cl == 0) {
2144                 SvCUR(dsv) = dsvcur;
2145                 pv = start;
2146                 utf8 = 0;
2147                 goto retry;
2148             }
2149         }
2150         else
2151             c = (*pv & 255);
2152
2153         switch (c) {
2154         case 0x00:
2155         case 0x01:
2156         case 0x02:
2157         case 0x03:
2158         case 0x04:
2159         case 0x05:
2160         case 0x06:
2161         case 0x07:
2162         case 0x08:
2163         case 0x0b:
2164         case 0x0c:
2165         case 0x0e:
2166         case 0x0f:
2167         case 0x10:
2168         case 0x11:
2169         case 0x12:
2170         case 0x13:
2171         case 0x14:
2172         case 0x15:
2173         case 0x16:
2174         case 0x17:
2175         case 0x18:
2176         case 0x19:
2177         case 0x1a:
2178         case 0x1b:
2179         case 0x1c:
2180         case 0x1d:
2181         case 0x1e:
2182         case 0x1f:
2183         case 0x7f:
2184         case 0x80:
2185         case 0x81:
2186         case 0x82:
2187         case 0x83:
2188         case 0x84:
2189         case 0x86:
2190         case 0x87:
2191         case 0x88:
2192         case 0x89:
2193         case 0x90:
2194         case 0x91:
2195         case 0x92:
2196         case 0x93:
2197         case 0x94:
2198         case 0x95:
2199         case 0x96:
2200         case 0x97:
2201         case 0x98:
2202         case 0x99:
2203         case 0x9a:
2204         case 0x9b:
2205         case 0x9c:
2206         case 0x9d:
2207         case 0x9e:
2208         case 0x9f:
2209             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2210             break;
2211         case '<':
2212             Perl_sv_catpvf(aTHX_ dsv, "&lt;");
2213             break;
2214         case '>':
2215             Perl_sv_catpvf(aTHX_ dsv, "&gt;");
2216             break;
2217         case '&':
2218             Perl_sv_catpvf(aTHX_ dsv, "&amp;");
2219             break;
2220         case '"':
2221             Perl_sv_catpvf(aTHX_ dsv, "&#34;");
2222             break;
2223         default:
2224             if (c < 0xD800) {
2225                 if (c < 32 || c > 127) {
2226                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2227                 }
2228                 else {
2229                     Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2230                 }
2231                 break;
2232             }
2233             if ((c >= 0xD800 && c <= 0xDB7F) ||
2234                 (c >= 0xDC00 && c <= 0xDFFF) ||
2235                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2236                  c > 0x10ffff)
2237                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2238             else
2239                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2240         }
2241
2242         if (utf8)
2243             pv += UTF8SKIP(pv);
2244         else
2245             pv++;
2246     }
2247
2248     return SvPVX(dsv);
2249 }
2250
2251 char *
2252 Perl_sv_xmlpeek(pTHX_ SV *sv)
2253 {
2254     SV *t = sv_newmortal();
2255     STRLEN n_a;
2256     int unref = 0;
2257
2258     sv_utf8_upgrade(t);
2259     sv_setpvn(t, "", 0);
2260     /* retry: */
2261     if (!sv) {
2262         sv_catpv(t, "VOID=\"\"");
2263         goto finish;
2264     }
2265     else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2266         sv_catpv(t, "WILD=\"\"");
2267         goto finish;
2268     }
2269     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2270         if (sv == &PL_sv_undef) {
2271             sv_catpv(t, "SV_UNDEF=\"1\"");
2272             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2273                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2274                 SvREADONLY(sv))
2275                 goto finish;
2276         }
2277         else if (sv == &PL_sv_no) {
2278             sv_catpv(t, "SV_NO=\"1\"");
2279             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2280                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2281                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2282                                   SVp_POK|SVp_NOK)) &&
2283                 SvCUR(sv) == 0 &&
2284                 SvNVX(sv) == 0.0)
2285                 goto finish;
2286         }
2287         else if (sv == &PL_sv_yes) {
2288             sv_catpv(t, "SV_YES=\"1\"");
2289             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2290                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2291                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2292                                   SVp_POK|SVp_NOK)) &&
2293                 SvCUR(sv) == 1 &&
2294                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2295                 SvNVX(sv) == 1.0)
2296                 goto finish;
2297         }
2298         else {
2299             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2300             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2301                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2302                 SvREADONLY(sv))
2303                 goto finish;
2304         }
2305         sv_catpv(t, " XXX=\"\" ");
2306     }
2307     else if (SvREFCNT(sv) == 0) {
2308         sv_catpv(t, " refcnt=\"0\"");
2309         unref++;
2310     }
2311     else if (DEBUG_R_TEST_) {
2312         int is_tmp = 0;
2313         I32 ix;
2314         /* is this SV on the tmps stack? */
2315         for (ix=PL_tmps_ix; ix>=0; ix--) {
2316             if (PL_tmps_stack[ix] == sv) {
2317                 is_tmp = 1;
2318                 break;
2319             }
2320         }
2321         if (SvREFCNT(sv) > 1)
2322             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2323                     is_tmp ? "T" : "");
2324         else if (is_tmp)
2325             sv_catpv(t, " DRT=\"<T>\"");
2326     }
2327
2328     if (SvROK(sv)) {
2329         sv_catpv(t, " ROK=\"\"");
2330     }
2331     switch (SvTYPE(sv)) {
2332     default:
2333         sv_catpv(t, " FREED=\"1\"");
2334         goto finish;
2335
2336     case SVt_NULL:
2337         sv_catpv(t, " UNDEF=\"1\"");
2338         goto finish;
2339     case SVt_IV:
2340         sv_catpv(t, " IV=\"");
2341         break;
2342     case SVt_NV:
2343         sv_catpv(t, " NV=\"");
2344         break;
2345     case SVt_RV:
2346         sv_catpv(t, " RV=\"");
2347         break;
2348     case SVt_PV:
2349         sv_catpv(t, " PV=\"");
2350         break;
2351     case SVt_PVIV:
2352         sv_catpv(t, " PVIV=\"");
2353         break;
2354     case SVt_PVNV:
2355         sv_catpv(t, " PVNV=\"");
2356         break;
2357     case SVt_PVMG:
2358         sv_catpv(t, " PVMG=\"");
2359         break;
2360     case SVt_PVLV:
2361         sv_catpv(t, " PVLV=\"");
2362         break;
2363     case SVt_PVAV:
2364         sv_catpv(t, " AV=\"");
2365         break;
2366     case SVt_PVHV:
2367         sv_catpv(t, " HV=\"");
2368         break;
2369     case SVt_PVCV:
2370         if (CvGV(sv))
2371             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2372         else
2373             sv_catpv(t, " CV=\"()\"");
2374         goto finish;
2375     case SVt_PVGV:
2376         sv_catpv(t, " GV=\"");
2377         break;
2378     case SVt_BIND:
2379         sv_catpv(t, " BIND=\"");
2380         break;
2381     case SVt_PVFM:
2382         sv_catpv(t, " FM=\"");
2383         break;
2384     case SVt_PVIO:
2385         sv_catpv(t, " IO=\"");
2386         break;
2387     }
2388
2389     if (SvPOKp(sv)) {
2390         if (SvPVX(sv)) {
2391             sv_catxmlsv(t, sv);
2392         }
2393     }
2394     else if (SvNOKp(sv)) {
2395         STORE_NUMERIC_LOCAL_SET_STANDARD();
2396         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2397         RESTORE_NUMERIC_LOCAL();
2398     }
2399     else if (SvIOKp(sv)) {
2400         if (SvIsUV(sv))
2401             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2402         else
2403             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2404     }
2405     else
2406         sv_catpv(t, "");
2407     sv_catpv(t, "\"");
2408
2409   finish:
2410     if (unref) {
2411         while (unref--)
2412             sv_catpv(t, ")");
2413     }
2414     return SvPV(t, n_a);
2415 }
2416
2417 void
2418 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2419 {
2420     if (!pm) {
2421         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2422         return;
2423     }
2424     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2425     level++;
2426     if (PM_GETRE(pm)) {
2427         char *s = PM_GETRE(pm)->precomp;
2428         SV *tmpsv = newSVpvn("",0);
2429         SvUTF8_on(tmpsv);
2430         sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2431         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2432              SvPVX(tmpsv));
2433         SvREFCNT_dec(tmpsv);
2434         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2435              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2436     }
2437     else
2438         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2439     if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2440         SV * const tmpsv = pm_description(pm);
2441         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2442         SvREFCNT_dec(tmpsv);
2443     }
2444
2445     level--;
2446     if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
2447         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2448         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2449         do_op_xmldump(level+2, file, pm->op_pmreplroot);
2450         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2451         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2452     }
2453     else
2454         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2455 }
2456
2457 void
2458 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2459 {
2460     do_pmop_xmldump(0, PL_xmlfp, pm);
2461 }
2462
2463 void
2464 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2465 {
2466     UV      seq;
2467     int     contents = 0;
2468     if (!o)
2469         return;
2470     sequence(o);
2471     seq = sequence_num(o);
2472     Perl_xmldump_indent(aTHX_ level, file,
2473         "<op_%s seq=\"%"UVuf" -> ",
2474              OP_NAME(o),
2475                       seq);
2476     level++;
2477     if (o->op_next)
2478         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2479                       sequence_num(o->op_next));
2480     else
2481         PerlIO_printf(file, "DONE\"");
2482
2483     if (o->op_targ) {
2484         if (o->op_type == OP_NULL)
2485         {
2486             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2487             if (o->op_targ == OP_NEXTSTATE)
2488             {
2489                 if (CopLINE(cCOPo))
2490                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2491                                      (UV)CopLINE(cCOPo));
2492                 if (CopSTASHPV(cCOPo))
2493                     PerlIO_printf(file, " package=\"%s\"",
2494                                      CopSTASHPV(cCOPo));
2495                 if (cCOPo->cop_label)
2496                     PerlIO_printf(file, " label=\"%s\"",
2497                                      cCOPo->cop_label);
2498             }
2499         }
2500         else
2501             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2502     }
2503 #ifdef DUMPADDR
2504     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2505 #endif
2506     if (o->op_flags) {
2507         SV *tmpsv = newSVpvn("", 0);
2508         switch (o->op_flags & OPf_WANT) {
2509         case OPf_WANT_VOID:
2510             sv_catpv(tmpsv, ",VOID");
2511             break;
2512         case OPf_WANT_SCALAR:
2513             sv_catpv(tmpsv, ",SCALAR");
2514             break;
2515         case OPf_WANT_LIST:
2516             sv_catpv(tmpsv, ",LIST");
2517             break;
2518         default:
2519             sv_catpv(tmpsv, ",UNKNOWN");
2520             break;
2521         }
2522         if (o->op_flags & OPf_KIDS)
2523             sv_catpv(tmpsv, ",KIDS");
2524         if (o->op_flags & OPf_PARENS)
2525             sv_catpv(tmpsv, ",PARENS");
2526         if (o->op_flags & OPf_STACKED)
2527             sv_catpv(tmpsv, ",STACKED");
2528         if (o->op_flags & OPf_REF)
2529             sv_catpv(tmpsv, ",REF");
2530         if (o->op_flags & OPf_MOD)
2531             sv_catpv(tmpsv, ",MOD");
2532         if (o->op_flags & OPf_SPECIAL)
2533             sv_catpv(tmpsv, ",SPECIAL");
2534         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2535         SvREFCNT_dec(tmpsv);
2536     }
2537     if (o->op_private) {
2538         SV *tmpsv = newSVpvn("", 0);
2539         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2540             if (o->op_private & OPpTARGET_MY)
2541                 sv_catpv(tmpsv, ",TARGET_MY");
2542         }
2543         else if (o->op_type == OP_LEAVESUB ||
2544                  o->op_type == OP_LEAVE ||
2545                  o->op_type == OP_LEAVESUBLV ||
2546                  o->op_type == OP_LEAVEWRITE) {
2547             if (o->op_private & OPpREFCOUNTED)
2548                 sv_catpv(tmpsv, ",REFCOUNTED");
2549         }
2550         else if (o->op_type == OP_AASSIGN) {
2551             if (o->op_private & OPpASSIGN_COMMON)
2552                 sv_catpv(tmpsv, ",COMMON");
2553         }
2554         else if (o->op_type == OP_SASSIGN) {
2555             if (o->op_private & OPpASSIGN_BACKWARDS)
2556                 sv_catpv(tmpsv, ",BACKWARDS");
2557         }
2558         else if (o->op_type == OP_TRANS) {
2559             if (o->op_private & OPpTRANS_SQUASH)
2560                 sv_catpv(tmpsv, ",SQUASH");
2561             if (o->op_private & OPpTRANS_DELETE)
2562                 sv_catpv(tmpsv, ",DELETE");
2563             if (o->op_private & OPpTRANS_COMPLEMENT)
2564                 sv_catpv(tmpsv, ",COMPLEMENT");
2565             if (o->op_private & OPpTRANS_IDENTICAL)
2566                 sv_catpv(tmpsv, ",IDENTICAL");
2567             if (o->op_private & OPpTRANS_GROWS)
2568                 sv_catpv(tmpsv, ",GROWS");
2569         }
2570         else if (o->op_type == OP_REPEAT) {
2571             if (o->op_private & OPpREPEAT_DOLIST)
2572                 sv_catpv(tmpsv, ",DOLIST");
2573         }
2574         else if (o->op_type == OP_ENTERSUB ||
2575                  o->op_type == OP_RV2SV ||
2576                  o->op_type == OP_GVSV ||
2577                  o->op_type == OP_RV2AV ||
2578                  o->op_type == OP_RV2HV ||
2579                  o->op_type == OP_RV2GV ||
2580                  o->op_type == OP_AELEM ||
2581                  o->op_type == OP_HELEM )
2582         {
2583             if (o->op_type == OP_ENTERSUB) {
2584                 if (o->op_private & OPpENTERSUB_AMPER)
2585                     sv_catpv(tmpsv, ",AMPER");
2586                 if (o->op_private & OPpENTERSUB_DB)
2587                     sv_catpv(tmpsv, ",DB");
2588                 if (o->op_private & OPpENTERSUB_HASTARG)
2589                     sv_catpv(tmpsv, ",HASTARG");
2590                 if (o->op_private & OPpENTERSUB_NOPAREN)
2591                     sv_catpv(tmpsv, ",NOPAREN");
2592                 if (o->op_private & OPpENTERSUB_INARGS)
2593                     sv_catpv(tmpsv, ",INARGS");
2594                 if (o->op_private & OPpENTERSUB_NOMOD)
2595                     sv_catpv(tmpsv, ",NOMOD");
2596             }
2597             else {
2598                 switch (o->op_private & OPpDEREF) {
2599             case OPpDEREF_SV:
2600                 sv_catpv(tmpsv, ",SV");
2601                 break;
2602             case OPpDEREF_AV:
2603                 sv_catpv(tmpsv, ",AV");
2604                 break;
2605             case OPpDEREF_HV:
2606                 sv_catpv(tmpsv, ",HV");
2607                 break;
2608             }
2609                 if (o->op_private & OPpMAYBE_LVSUB)
2610                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2611             }
2612             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2613                 if (o->op_private & OPpLVAL_DEFER)
2614                     sv_catpv(tmpsv, ",LVAL_DEFER");
2615             }
2616             else {
2617                 if (o->op_private & HINT_STRICT_REFS)
2618                     sv_catpv(tmpsv, ",STRICT_REFS");
2619                 if (o->op_private & OPpOUR_INTRO)
2620                     sv_catpv(tmpsv, ",OUR_INTRO");
2621             }
2622         }
2623         else if (o->op_type == OP_CONST) {
2624             if (o->op_private & OPpCONST_BARE)
2625                 sv_catpv(tmpsv, ",BARE");
2626             if (o->op_private & OPpCONST_STRICT)
2627                 sv_catpv(tmpsv, ",STRICT");
2628             if (o->op_private & OPpCONST_ARYBASE)
2629                 sv_catpv(tmpsv, ",ARYBASE");
2630             if (o->op_private & OPpCONST_WARNING)
2631                 sv_catpv(tmpsv, ",WARNING");
2632             if (o->op_private & OPpCONST_ENTERED)
2633                 sv_catpv(tmpsv, ",ENTERED");
2634         }
2635         else if (o->op_type == OP_FLIP) {
2636             if (o->op_private & OPpFLIP_LINENUM)
2637                 sv_catpv(tmpsv, ",LINENUM");
2638         }
2639         else if (o->op_type == OP_FLOP) {
2640             if (o->op_private & OPpFLIP_LINENUM)
2641                 sv_catpv(tmpsv, ",LINENUM");
2642         }
2643         else if (o->op_type == OP_RV2CV) {
2644             if (o->op_private & OPpLVAL_INTRO)
2645                 sv_catpv(tmpsv, ",INTRO");
2646         }
2647         else if (o->op_type == OP_GV) {
2648             if (o->op_private & OPpEARLY_CV)
2649                 sv_catpv(tmpsv, ",EARLY_CV");
2650         }
2651         else if (o->op_type == OP_LIST) {
2652             if (o->op_private & OPpLIST_GUESSED)
2653                 sv_catpv(tmpsv, ",GUESSED");
2654         }
2655         else if (o->op_type == OP_DELETE) {
2656             if (o->op_private & OPpSLICE)
2657                 sv_catpv(tmpsv, ",SLICE");
2658         }
2659         else if (o->op_type == OP_EXISTS) {
2660             if (o->op_private & OPpEXISTS_SUB)
2661                 sv_catpv(tmpsv, ",EXISTS_SUB");
2662         }
2663         else if (o->op_type == OP_SORT) {
2664             if (o->op_private & OPpSORT_NUMERIC)
2665                 sv_catpv(tmpsv, ",NUMERIC");
2666             if (o->op_private & OPpSORT_INTEGER)
2667                 sv_catpv(tmpsv, ",INTEGER");
2668             if (o->op_private & OPpSORT_REVERSE)
2669                 sv_catpv(tmpsv, ",REVERSE");
2670         }
2671         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2672             if (o->op_private & OPpOPEN_IN_RAW)
2673                 sv_catpv(tmpsv, ",IN_RAW");
2674             if (o->op_private & OPpOPEN_IN_CRLF)
2675                 sv_catpv(tmpsv, ",IN_CRLF");
2676             if (o->op_private & OPpOPEN_OUT_RAW)
2677                 sv_catpv(tmpsv, ",OUT_RAW");
2678             if (o->op_private & OPpOPEN_OUT_CRLF)
2679                 sv_catpv(tmpsv, ",OUT_CRLF");
2680         }
2681         else if (o->op_type == OP_EXIT) {
2682             if (o->op_private & OPpEXIT_VMSISH)
2683                 sv_catpv(tmpsv, ",EXIT_VMSISH");
2684             if (o->op_private & OPpHUSH_VMSISH)
2685                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2686         }
2687         else if (o->op_type == OP_DIE) {
2688             if (o->op_private & OPpHUSH_VMSISH)
2689                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2690         }
2691         else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2692             if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2693                 sv_catpv(tmpsv, ",FT_ACCESS");
2694             if (o->op_private & OPpFT_STACKED)
2695                 sv_catpv(tmpsv, ",FT_STACKED");
2696         }
2697         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2698             sv_catpv(tmpsv, ",INTRO");
2699         if (SvCUR(tmpsv))
2700             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2701         SvREFCNT_dec(tmpsv);
2702     }
2703
2704     switch (o->op_type) {
2705     case OP_AELEMFAST:
2706         if (o->op_flags & OPf_SPECIAL) {
2707             break;
2708         }
2709     case OP_GVSV:
2710     case OP_GV:
2711 #ifdef USE_ITHREADS
2712         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2713 #else
2714         if (cSVOPo->op_sv) {
2715             SV *tmpsv1 = newSV(0);
2716             SV *tmpsv2 = newSVpvn("",0);
2717             char *s;
2718             STRLEN len;
2719             SvUTF8_on(tmpsv1);
2720             SvUTF8_on(tmpsv2);
2721             ENTER;
2722             SAVEFREESV(tmpsv1);
2723             SAVEFREESV(tmpsv2);
2724             gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2725             s = SvPV(tmpsv1,len);
2726             sv_catxmlpvn(tmpsv2, s, len, 1);
2727             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2728             LEAVE;
2729         }
2730         else
2731             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2732 #endif
2733         break;
2734     case OP_CONST:
2735     case OP_METHOD_NAMED:
2736 #ifndef USE_ITHREADS
2737         /* with ITHREADS, consts are stored in the pad, and the right pad
2738          * may not be active here, so skip */
2739         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2740 #endif
2741         break;
2742     case OP_ANONCODE:
2743         if (!contents) {
2744             contents = 1;
2745             PerlIO_printf(file, ">\n");
2746         }
2747         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2748         break;
2749     case OP_SETSTATE:
2750     case OP_NEXTSTATE:
2751     case OP_DBSTATE:
2752         if (CopLINE(cCOPo))
2753             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2754                              (UV)CopLINE(cCOPo));
2755         if (CopSTASHPV(cCOPo))
2756             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2757                              CopSTASHPV(cCOPo));
2758         if (cCOPo->cop_label)
2759             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2760                              cCOPo->cop_label);
2761         break;
2762     case OP_ENTERLOOP:
2763         S_xmldump_attr(aTHX_ level, file, "redo=\"");
2764         if (cLOOPo->op_redoop)
2765             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2766         else
2767             PerlIO_printf(file, "DONE\"");
2768         S_xmldump_attr(aTHX_ level, file, "next=\"");
2769         if (cLOOPo->op_nextop)
2770             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2771         else
2772             PerlIO_printf(file, "DONE\"");
2773         S_xmldump_attr(aTHX_ level, file, "last=\"");
2774         if (cLOOPo->op_lastop)
2775             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2776         else
2777             PerlIO_printf(file, "DONE\"");
2778         break;
2779     case OP_COND_EXPR:
2780     case OP_RANGE:
2781     case OP_MAPWHILE:
2782     case OP_GREPWHILE:
2783     case OP_OR:
2784     case OP_AND:
2785         S_xmldump_attr(aTHX_ level, file, "other=\"");
2786         if (cLOGOPo->op_other)
2787             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2788         else
2789             PerlIO_printf(file, "DONE\"");
2790         break;
2791     case OP_LEAVE:
2792     case OP_LEAVEEVAL:
2793     case OP_LEAVESUB:
2794     case OP_LEAVESUBLV:
2795     case OP_LEAVEWRITE:
2796     case OP_SCOPE:
2797         if (o->op_private & OPpREFCOUNTED)
2798             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2799         break;
2800     default:
2801         break;
2802     }
2803
2804     if (PL_madskills && o->op_madprop) {
2805         SV *tmpsv = newSVpvn("", 0);
2806         MADPROP* mp = o->op_madprop;
2807         sv_utf8_upgrade(tmpsv);
2808         if (!contents) {
2809             contents = 1;
2810             PerlIO_printf(file, ">\n");
2811         }
2812         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2813         level++;
2814         while (mp) {
2815             char tmp = mp->mad_key;
2816             sv_setpvn(tmpsv,"\"",1);
2817             if (tmp)
2818                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2819             sv_catpv(tmpsv, "\"");
2820             switch (mp->mad_type) {
2821             case MAD_NULL:
2822                 sv_catpv(tmpsv, "NULL");
2823                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2824                 break;
2825             case MAD_PV:
2826                 sv_catpv(tmpsv, " val=\"");
2827                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2828                 sv_catpv(tmpsv, "\"");
2829                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2830                 break;
2831             case MAD_SV:
2832                 sv_catpv(tmpsv, " val=\"");
2833                 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2834                 sv_catpv(tmpsv, "\"");
2835                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2836                 break;
2837             case MAD_OP:
2838                 if ((OP*)mp->mad_val) {
2839                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2840                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2841                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2842                 }
2843                 break;
2844             default:
2845                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2846                 break;
2847             }
2848             mp = mp->mad_next;
2849         }
2850         level--;
2851         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2852
2853         SvREFCNT_dec(tmpsv);
2854     }
2855
2856     switch (o->op_type) {
2857     case OP_PUSHRE:
2858     case OP_MATCH:
2859     case OP_QR:
2860     case OP_SUBST:
2861         if (!contents) {
2862             contents = 1;
2863             PerlIO_printf(file, ">\n");
2864         }
2865         do_pmop_xmldump(level, file, cPMOPo);
2866         break;
2867     default:
2868         break;
2869     }
2870
2871     if (o->op_flags & OPf_KIDS) {
2872         OP *kid;
2873         if (!contents) {
2874             contents = 1;
2875             PerlIO_printf(file, ">\n");
2876         }
2877         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2878             do_op_xmldump(level, file, kid);
2879     }
2880
2881     if (contents)
2882         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2883     else
2884         PerlIO_printf(file, " />\n");
2885 }
2886
2887 void
2888 Perl_op_xmldump(pTHX_ const OP *o)
2889 {
2890     do_op_xmldump(0, PL_xmlfp, o);
2891 }
2892 #endif
2893
2894 /*
2895  * Local variables:
2896  * c-indentation-style: bsd
2897  * c-basic-offset: 4
2898  * indent-tabs-mode: t
2899  * End:
2900  *
2901  * ex: set ts=8 sts=4 sw=4 noet:
2902  */