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