dump.c

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