dump.c

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