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