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     do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1883 }
1884
1885 int
1886 Perl_runops_debug(pTHX)
1887 {
1888     dVAR;
1889     if (!PL_op) {
1890         if (ckWARN_d(WARN_DEBUGGING))
1891             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1892         return 0;
1893     }
1894
1895     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1896     do {
1897         PERL_ASYNC_CHECK();
1898         if (PL_debug) {
1899             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1900                 PerlIO_printf(Perl_debug_log,
1901                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1902                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1903                               PTR2UV(*PL_watchaddr));
1904             if (DEBUG_s_TEST_) {
1905                 if (DEBUG_v_TEST_) {
1906                     PerlIO_printf(Perl_debug_log, "\n");
1907                     deb_stack_all();
1908                 }
1909                 else
1910                     debstack();
1911             }
1912
1913
1914             if (DEBUG_t_TEST_) debop(PL_op);
1915             if (DEBUG_P_TEST_) debprof(PL_op);
1916         }
1917     } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1918     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1919
1920     TAINT_NOT;
1921     return 0;
1922 }
1923
1924 I32
1925 Perl_debop(pTHX_ const OP *o)
1926 {
1927     dVAR;
1928     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1929         return 0;
1930
1931     Perl_deb(aTHX_ "%s", OP_NAME(o));
1932     switch (o->op_type) {
1933     case OP_CONST:
1934         PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1935         break;
1936     case OP_GVSV:
1937     case OP_GV:
1938         if (cGVOPo_gv) {
1939             SV * const sv = newSV(0);
1940 #ifdef PERL_MAD
1941             /* FIXME - is this making unwarranted assumptions about the
1942                UTF-8 cleanliness of the dump file handle?  */
1943             SvUTF8_on(sv);
1944 #endif
1945             gv_fullname3(sv, cGVOPo_gv, NULL);
1946             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1947             SvREFCNT_dec(sv);
1948         }
1949         else
1950             PerlIO_printf(Perl_debug_log, "(NULL)");
1951         break;
1952     case OP_PADSV:
1953     case OP_PADAV:
1954     case OP_PADHV:
1955         {
1956         /* print the lexical's name */
1957         CV * const cv = deb_curcv(cxstack_ix);
1958         SV *sv;
1959         if (cv) {
1960             AV * const padlist = CvPADLIST(cv);
1961             AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1962             sv = *av_fetch(comppad, o->op_targ, FALSE);
1963         } else
1964             sv = NULL;
1965         if (sv)
1966             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1967         else
1968             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1969         }
1970         break;
1971     default:
1972         break;
1973     }
1974     PerlIO_printf(Perl_debug_log, "\n");
1975     return 0;
1976 }
1977
1978 STATIC CV*
1979 S_deb_curcv(pTHX_ const I32 ix)
1980 {
1981     dVAR;
1982     const PERL_CONTEXT * const cx = &cxstack[ix];
1983     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1984         return cx->blk_sub.cv;
1985     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1986         return PL_compcv;
1987     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1988         return PL_main_cv;
1989     else if (ix <= 0)
1990         return NULL;
1991     else
1992         return deb_curcv(ix - 1);
1993 }
1994
1995 void
1996 Perl_watch(pTHX_ char **addr)
1997 {
1998     dVAR;
1999     PL_watchaddr = addr;
2000     PL_watchok = *addr;
2001     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2002         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2003 }
2004
2005 STATIC void
2006 S_debprof(pTHX_ const OP *o)
2007 {
2008     dVAR;
2009     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2010         return;
2011     if (!PL_profiledata)
2012         Newxz(PL_profiledata, MAXO, U32);
2013     ++PL_profiledata[o->op_type];
2014 }
2015
2016 void
2017 Perl_debprofdump(pTHX)
2018 {
2019     dVAR;
2020     unsigned i;
2021     if (!PL_profiledata)
2022         return;
2023     for (i = 0; i < MAXO; i++) {
2024         if (PL_profiledata[i])
2025             PerlIO_printf(Perl_debug_log,
2026                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2027                                        PL_op_name[i]);
2028     }
2029 }
2030
2031 #ifdef PERL_MAD
2032 /*
2033  *    XML variants of most of the above routines
2034  */
2035
2036 STATIC void
2037 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2038 {
2039     va_list args;
2040     PerlIO_printf(file, "\n    ");
2041     va_start(args, pat);
2042     xmldump_vindent(level, file, pat, &args);
2043     va_end(args);
2044 }
2045
2046
2047 void
2048 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2049 {
2050     va_list args;
2051     va_start(args, pat);
2052     xmldump_vindent(level, file, pat, &args);
2053     va_end(args);
2054 }
2055
2056 void
2057 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2058 {
2059     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2060     PerlIO_vprintf(file, pat, *args);
2061 }
2062
2063 void
2064 Perl_xmldump_all(pTHX)
2065 {
2066     PerlIO_setlinebuf(PL_xmlfp);
2067     if (PL_main_root)
2068         op_xmldump(PL_main_root);
2069     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2070         PerlIO_close(PL_xmlfp);
2071     PL_xmlfp = 0;
2072 }
2073
2074 void
2075 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2076 {
2077     I32 i;
2078     HE  *entry;
2079
2080     if (!HvARRAY(stash))
2081         return;
2082     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2083         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2084             GV *gv = (GV*)HeVAL(entry);
2085             HV *hv;
2086             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2087                 continue;
2088             if (GvCVu(gv))
2089                 xmldump_sub(gv);
2090             if (GvFORM(gv))
2091                 xmldump_form(gv);
2092             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2093                 && (hv = GvHV(gv)) && hv != PL_defstash)
2094                 xmldump_packsubs(hv);           /* nested package */
2095         }
2096     }
2097 }
2098
2099 void
2100 Perl_xmldump_sub(pTHX_ const GV *gv)
2101 {
2102     SV * const sv = sv_newmortal();
2103
2104     gv_fullname3(sv, gv, Nullch);
2105     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2106     if (CvXSUB(GvCV(gv)))
2107         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2108             PTR2UV(CvXSUB(GvCV(gv))),
2109             (int)CvXSUBANY(GvCV(gv)).any_i32);
2110     else if (CvROOT(GvCV(gv)))
2111         op_xmldump(CvROOT(GvCV(gv)));
2112     else
2113         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2114 }
2115
2116 void
2117 Perl_xmldump_form(pTHX_ const GV *gv)
2118 {
2119     SV * const sv = sv_newmortal();
2120
2121     gv_fullname3(sv, gv, Nullch);
2122     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2123     if (CvROOT(GvFORM(gv)))
2124         op_xmldump(CvROOT(GvFORM(gv)));
2125     else
2126         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2127 }
2128
2129 void
2130 Perl_xmldump_eval(pTHX)
2131 {
2132     op_xmldump(PL_eval_root);
2133 }
2134
2135 char *
2136 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2137 {
2138     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2139 }
2140
2141 char *
2142 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2143 {
2144     unsigned int c;
2145     const char * const e = pv + len;
2146     const char * const start = pv;
2147     STRLEN dsvcur;
2148     STRLEN cl;
2149
2150     sv_catpvn(dsv,"",0);
2151     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2152
2153   retry:
2154     while (pv < e) {
2155         if (utf8) {
2156             c = utf8_to_uvchr((U8*)pv, &cl);
2157             if (cl == 0) {
2158                 SvCUR(dsv) = dsvcur;
2159                 pv = start;
2160                 utf8 = 0;
2161                 goto retry;
2162             }
2163         }
2164         else
2165             c = (*pv & 255);
2166
2167         switch (c) {
2168         case 0x00:
2169         case 0x01:
2170         case 0x02:
2171         case 0x03:
2172         case 0x04:
2173         case 0x05:
2174         case 0x06:
2175         case 0x07:
2176         case 0x08:
2177         case 0x0b:
2178         case 0x0c:
2179         case 0x0e:
2180         case 0x0f:
2181         case 0x10:
2182         case 0x11:
2183         case 0x12:
2184         case 0x13:
2185         case 0x14:
2186         case 0x15:
2187         case 0x16:
2188         case 0x17:
2189         case 0x18:
2190         case 0x19:
2191         case 0x1a:
2192         case 0x1b:
2193         case 0x1c:
2194         case 0x1d:
2195         case 0x1e:
2196         case 0x1f:
2197         case 0x7f:
2198         case 0x80:
2199         case 0x81:
2200         case 0x82:
2201         case 0x83:
2202         case 0x84:
2203         case 0x86:
2204         case 0x87:
2205         case 0x88:
2206         case 0x89:
2207         case 0x90:
2208         case 0x91:
2209         case 0x92:
2210         case 0x93:
2211         case 0x94:
2212         case 0x95:
2213         case 0x96:
2214         case 0x97:
2215         case 0x98:
2216         case 0x99:
2217         case 0x9a:
2218         case 0x9b:
2219         case 0x9c:
2220         case 0x9d:
2221         case 0x9e:
2222         case 0x9f:
2223             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2224             break;
2225         case '<':
2226             Perl_sv_catpvf(aTHX_ dsv, "&lt;");
2227             break;
2228         case '>':
2229             Perl_sv_catpvf(aTHX_ dsv, "&gt;");
2230             break;
2231         case '&':
2232             Perl_sv_catpvf(aTHX_ dsv, "&amp;");
2233             break;
2234         case '"':
2235             Perl_sv_catpvf(aTHX_ dsv, "&#34;");
2236             break;
2237         default:
2238             if (c < 0xD800) {
2239                 if (c < 32 || c > 127) {
2240                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2241                 }
2242                 else {
2243                     Perl_sv_catpvf(aTHX_ dsv, "%c", c);
2244                 }
2245                 break;
2246             }
2247             if ((c >= 0xD800 && c <= 0xDB7F) ||
2248                 (c >= 0xDC00 && c <= 0xDFFF) ||
2249                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2250                  c > 0x10ffff)
2251                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2252             else
2253                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2254         }
2255
2256         if (utf8)
2257             pv += UTF8SKIP(pv);
2258         else
2259             pv++;
2260     }
2261
2262     return SvPVX(dsv);
2263 }
2264
2265 char *
2266 Perl_sv_xmlpeek(pTHX_ SV *sv)
2267 {
2268     SV * const t = sv_newmortal();
2269     STRLEN n_a;
2270     int unref = 0;
2271
2272     sv_utf8_upgrade(t);
2273     sv_setpvn(t, "", 0);
2274     /* retry: */
2275     if (!sv) {
2276         sv_catpv(t, "VOID=\"\"");
2277         goto finish;
2278     }
2279     else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2280         sv_catpv(t, "WILD=\"\"");
2281         goto finish;
2282     }
2283     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2284         if (sv == &PL_sv_undef) {
2285             sv_catpv(t, "SV_UNDEF=\"1\"");
2286             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2287                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2288                 SvREADONLY(sv))
2289                 goto finish;
2290         }
2291         else if (sv == &PL_sv_no) {
2292             sv_catpv(t, "SV_NO=\"1\"");
2293             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2294                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2295                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2296                                   SVp_POK|SVp_NOK)) &&
2297                 SvCUR(sv) == 0 &&
2298                 SvNVX(sv) == 0.0)
2299                 goto finish;
2300         }
2301         else if (sv == &PL_sv_yes) {
2302             sv_catpv(t, "SV_YES=\"1\"");
2303             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2304                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2305                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2306                                   SVp_POK|SVp_NOK)) &&
2307                 SvCUR(sv) == 1 &&
2308                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2309                 SvNVX(sv) == 1.0)
2310                 goto finish;
2311         }
2312         else {
2313             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2314             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2315                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2316                 SvREADONLY(sv))
2317                 goto finish;
2318         }
2319         sv_catpv(t, " XXX=\"\" ");
2320     }
2321     else if (SvREFCNT(sv) == 0) {
2322         sv_catpv(t, " refcnt=\"0\"");
2323         unref++;
2324     }
2325     else if (DEBUG_R_TEST_) {
2326         int is_tmp = 0;
2327         I32 ix;
2328         /* is this SV on the tmps stack? */
2329         for (ix=PL_tmps_ix; ix>=0; ix--) {
2330             if (PL_tmps_stack[ix] == sv) {
2331                 is_tmp = 1;
2332                 break;
2333             }
2334         }
2335         if (SvREFCNT(sv) > 1)
2336             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2337                     is_tmp ? "T" : "");
2338         else if (is_tmp)
2339             sv_catpv(t, " DRT=\"<T>\"");
2340     }
2341
2342     if (SvROK(sv)) {
2343         sv_catpv(t, " ROK=\"\"");
2344     }
2345     switch (SvTYPE(sv)) {
2346     default:
2347         sv_catpv(t, " FREED=\"1\"");
2348         goto finish;
2349
2350     case SVt_NULL:
2351         sv_catpv(t, " UNDEF=\"1\"");
2352         goto finish;
2353     case SVt_IV:
2354         sv_catpv(t, " IV=\"");
2355         break;
2356     case SVt_NV:
2357         sv_catpv(t, " NV=\"");
2358         break;
2359     case SVt_RV:
2360         sv_catpv(t, " RV=\"");
2361         break;
2362     case SVt_PV:
2363         sv_catpv(t, " PV=\"");
2364         break;
2365     case SVt_PVIV:
2366         sv_catpv(t, " PVIV=\"");
2367         break;
2368     case SVt_PVNV:
2369         sv_catpv(t, " PVNV=\"");
2370         break;
2371     case SVt_PVMG:
2372         sv_catpv(t, " PVMG=\"");
2373         break;
2374     case SVt_PVLV:
2375         sv_catpv(t, " PVLV=\"");
2376         break;
2377     case SVt_PVAV:
2378         sv_catpv(t, " AV=\"");
2379         break;
2380     case SVt_PVHV:
2381         sv_catpv(t, " HV=\"");
2382         break;
2383     case SVt_PVCV:
2384         if (CvGV(sv))
2385             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2386         else
2387             sv_catpv(t, " CV=\"()\"");
2388         goto finish;
2389     case SVt_PVGV:
2390         sv_catpv(t, " GV=\"");
2391         break;
2392     case SVt_BIND:
2393         sv_catpv(t, " BIND=\"");
2394         break;
2395     case SVt_PVFM:
2396         sv_catpv(t, " FM=\"");
2397         break;
2398     case SVt_PVIO:
2399         sv_catpv(t, " IO=\"");
2400         break;
2401     }
2402
2403     if (SvPOKp(sv)) {
2404         if (SvPVX(sv)) {
2405             sv_catxmlsv(t, sv);
2406         }
2407     }
2408     else if (SvNOKp(sv)) {
2409         STORE_NUMERIC_LOCAL_SET_STANDARD();
2410         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2411         RESTORE_NUMERIC_LOCAL();
2412     }
2413     else if (SvIOKp(sv)) {
2414         if (SvIsUV(sv))
2415             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2416         else
2417             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2418     }
2419     else
2420         sv_catpv(t, "");
2421     sv_catpv(t, "\"");
2422
2423   finish:
2424     while (unref--)
2425         sv_catpv(t, ")");
2426     return SvPV(t, n_a);
2427 }
2428
2429 void
2430 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2431 {
2432     if (!pm) {
2433         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2434         return;
2435     }
2436     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2437     level++;
2438     if (PM_GETRE(pm)) {
2439         const char * const s = PM_GETRE(pm)->precomp;
2440         SV * const tmpsv = newSVpvn("",0);
2441         SvUTF8_on(tmpsv);
2442         sv_catxmlpvn(tmpsv, s, strlen(s), 1);
2443         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2444              SvPVX(tmpsv));
2445         SvREFCNT_dec(tmpsv);
2446         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2447              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2448     }
2449     else
2450         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2451     if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2452         SV * const tmpsv = pm_description(pm);
2453         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2454         SvREFCNT_dec(tmpsv);
2455     }
2456
2457     level--;
2458     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2459         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2460         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2461         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2462         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2463         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2464     }
2465     else
2466         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2467 }
2468
2469 void
2470 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2471 {
2472     do_pmop_xmldump(0, PL_xmlfp, pm);
2473 }
2474
2475 void
2476 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2477 {
2478     UV      seq;
2479     int     contents = 0;
2480     if (!o)
2481         return;
2482     sequence(o);
2483     seq = sequence_num(o);
2484     Perl_xmldump_indent(aTHX_ level, file,
2485         "<op_%s seq=\"%"UVuf" -> ",
2486              OP_NAME(o),
2487                       seq);
2488     level++;
2489     if (o->op_next)
2490         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2491                       sequence_num(o->op_next));
2492     else
2493         PerlIO_printf(file, "DONE\"");
2494
2495     if (o->op_targ) {
2496         if (o->op_type == OP_NULL)
2497         {
2498             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2499             if (o->op_targ == OP_NEXTSTATE)
2500             {
2501                 if (CopLINE(cCOPo))
2502                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2503                                      (UV)CopLINE(cCOPo));
2504                 if (CopSTASHPV(cCOPo))
2505                     PerlIO_printf(file, " package=\"%s\"",
2506                                      CopSTASHPV(cCOPo));
2507                 if (cCOPo->cop_label)
2508                     PerlIO_printf(file, " label=\"%s\"",
2509                                      cCOPo->cop_label);
2510             }
2511         }
2512         else
2513             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2514     }
2515 #ifdef DUMPADDR
2516     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2517 #endif
2518     if (o->op_flags) {
2519         SV * const tmpsv = newSVpvn("", 0);
2520         switch (o->op_flags & OPf_WANT) {
2521         case OPf_WANT_VOID:
2522             sv_catpv(tmpsv, ",VOID");
2523             break;
2524         case OPf_WANT_SCALAR:
2525             sv_catpv(tmpsv, ",SCALAR");
2526             break;
2527         case OPf_WANT_LIST:
2528             sv_catpv(tmpsv, ",LIST");
2529             break;
2530         default:
2531             sv_catpv(tmpsv, ",UNKNOWN");
2532             break;
2533         }
2534         if (o->op_flags & OPf_KIDS)
2535             sv_catpv(tmpsv, ",KIDS");
2536         if (o->op_flags & OPf_PARENS)
2537             sv_catpv(tmpsv, ",PARENS");
2538         if (o->op_flags & OPf_STACKED)
2539             sv_catpv(tmpsv, ",STACKED");
2540         if (o->op_flags & OPf_REF)
2541             sv_catpv(tmpsv, ",REF");
2542         if (o->op_flags & OPf_MOD)
2543             sv_catpv(tmpsv, ",MOD");
2544         if (o->op_flags & OPf_SPECIAL)
2545             sv_catpv(tmpsv, ",SPECIAL");
2546         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2547         SvREFCNT_dec(tmpsv);
2548     }
2549     if (o->op_private) {
2550         SV * const tmpsv = newSVpvn("", 0);
2551         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2552             if (o->op_private & OPpTARGET_MY)
2553                 sv_catpv(tmpsv, ",TARGET_MY");
2554         }
2555         else if (o->op_type == OP_LEAVESUB ||
2556                  o->op_type == OP_LEAVE ||
2557                  o->op_type == OP_LEAVESUBLV ||
2558                  o->op_type == OP_LEAVEWRITE) {
2559             if (o->op_private & OPpREFCOUNTED)
2560                 sv_catpv(tmpsv, ",REFCOUNTED");
2561         }
2562         else if (o->op_type == OP_AASSIGN) {
2563             if (o->op_private & OPpASSIGN_COMMON)
2564                 sv_catpv(tmpsv, ",COMMON");
2565         }
2566         else if (o->op_type == OP_SASSIGN) {
2567             if (o->op_private & OPpASSIGN_BACKWARDS)
2568                 sv_catpv(tmpsv, ",BACKWARDS");
2569         }
2570         else if (o->op_type == OP_TRANS) {
2571             if (o->op_private & OPpTRANS_SQUASH)
2572                 sv_catpv(tmpsv, ",SQUASH");
2573             if (o->op_private & OPpTRANS_DELETE)
2574                 sv_catpv(tmpsv, ",DELETE");
2575             if (o->op_private & OPpTRANS_COMPLEMENT)
2576                 sv_catpv(tmpsv, ",COMPLEMENT");
2577             if (o->op_private & OPpTRANS_IDENTICAL)
2578                 sv_catpv(tmpsv, ",IDENTICAL");
2579             if (o->op_private & OPpTRANS_GROWS)
2580                 sv_catpv(tmpsv, ",GROWS");
2581         }
2582         else if (o->op_type == OP_REPEAT) {
2583             if (o->op_private & OPpREPEAT_DOLIST)
2584                 sv_catpv(tmpsv, ",DOLIST");
2585         }
2586         else if (o->op_type == OP_ENTERSUB ||
2587                  o->op_type == OP_RV2SV ||
2588                  o->op_type == OP_GVSV ||
2589                  o->op_type == OP_RV2AV ||
2590                  o->op_type == OP_RV2HV ||
2591                  o->op_type == OP_RV2GV ||
2592                  o->op_type == OP_AELEM ||
2593                  o->op_type == OP_HELEM )
2594         {
2595             if (o->op_type == OP_ENTERSUB) {
2596                 if (o->op_private & OPpENTERSUB_AMPER)
2597                     sv_catpv(tmpsv, ",AMPER");
2598                 if (o->op_private & OPpENTERSUB_DB)
2599                     sv_catpv(tmpsv, ",DB");
2600                 if (o->op_private & OPpENTERSUB_HASTARG)
2601                     sv_catpv(tmpsv, ",HASTARG");
2602                 if (o->op_private & OPpENTERSUB_NOPAREN)
2603                     sv_catpv(tmpsv, ",NOPAREN");
2604                 if (o->op_private & OPpENTERSUB_INARGS)
2605                     sv_catpv(tmpsv, ",INARGS");
2606                 if (o->op_private & OPpENTERSUB_NOMOD)
2607                     sv_catpv(tmpsv, ",NOMOD");
2608             }
2609             else {
2610                 switch (o->op_private & OPpDEREF) {
2611             case OPpDEREF_SV:
2612                 sv_catpv(tmpsv, ",SV");
2613                 break;
2614             case OPpDEREF_AV:
2615                 sv_catpv(tmpsv, ",AV");
2616                 break;
2617             case OPpDEREF_HV:
2618                 sv_catpv(tmpsv, ",HV");
2619                 break;
2620             }
2621                 if (o->op_private & OPpMAYBE_LVSUB)
2622                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2623             }
2624             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2625                 if (o->op_private & OPpLVAL_DEFER)
2626                     sv_catpv(tmpsv, ",LVAL_DEFER");
2627             }
2628             else {
2629                 if (o->op_private & HINT_STRICT_REFS)
2630                     sv_catpv(tmpsv, ",STRICT_REFS");
2631                 if (o->op_private & OPpOUR_INTRO)
2632                     sv_catpv(tmpsv, ",OUR_INTRO");
2633             }
2634         }
2635         else if (o->op_type == OP_CONST) {
2636             if (o->op_private & OPpCONST_BARE)
2637                 sv_catpv(tmpsv, ",BARE");
2638             if (o->op_private & OPpCONST_STRICT)
2639                 sv_catpv(tmpsv, ",STRICT");
2640             if (o->op_private & OPpCONST_ARYBASE)
2641                 sv_catpv(tmpsv, ",ARYBASE");
2642             if (o->op_private & OPpCONST_WARNING)
2643                 sv_catpv(tmpsv, ",WARNING");
2644             if (o->op_private & OPpCONST_ENTERED)
2645                 sv_catpv(tmpsv, ",ENTERED");
2646         }
2647         else if (o->op_type == OP_FLIP) {
2648             if (o->op_private & OPpFLIP_LINENUM)
2649                 sv_catpv(tmpsv, ",LINENUM");
2650         }
2651         else if (o->op_type == OP_FLOP) {
2652             if (o->op_private & OPpFLIP_LINENUM)
2653                 sv_catpv(tmpsv, ",LINENUM");
2654         }
2655         else if (o->op_type == OP_RV2CV) {
2656             if (o->op_private & OPpLVAL_INTRO)
2657                 sv_catpv(tmpsv, ",INTRO");
2658         }
2659         else if (o->op_type == OP_GV) {
2660             if (o->op_private & OPpEARLY_CV)
2661                 sv_catpv(tmpsv, ",EARLY_CV");
2662         }
2663         else if (o->op_type == OP_LIST) {
2664             if (o->op_private & OPpLIST_GUESSED)
2665                 sv_catpv(tmpsv, ",GUESSED");
2666         }
2667         else if (o->op_type == OP_DELETE) {
2668             if (o->op_private & OPpSLICE)
2669                 sv_catpv(tmpsv, ",SLICE");
2670         }
2671         else if (o->op_type == OP_EXISTS) {
2672             if (o->op_private & OPpEXISTS_SUB)
2673                 sv_catpv(tmpsv, ",EXISTS_SUB");
2674         }
2675         else if (o->op_type == OP_SORT) {
2676             if (o->op_private & OPpSORT_NUMERIC)
2677                 sv_catpv(tmpsv, ",NUMERIC");
2678             if (o->op_private & OPpSORT_INTEGER)
2679                 sv_catpv(tmpsv, ",INTEGER");
2680             if (o->op_private & OPpSORT_REVERSE)
2681                 sv_catpv(tmpsv, ",REVERSE");
2682         }
2683         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2684             if (o->op_private & OPpOPEN_IN_RAW)
2685                 sv_catpv(tmpsv, ",IN_RAW");
2686             if (o->op_private & OPpOPEN_IN_CRLF)
2687                 sv_catpv(tmpsv, ",IN_CRLF");
2688             if (o->op_private & OPpOPEN_OUT_RAW)
2689                 sv_catpv(tmpsv, ",OUT_RAW");
2690             if (o->op_private & OPpOPEN_OUT_CRLF)
2691                 sv_catpv(tmpsv, ",OUT_CRLF");
2692         }
2693         else if (o->op_type == OP_EXIT) {
2694             if (o->op_private & OPpEXIT_VMSISH)
2695                 sv_catpv(tmpsv, ",EXIT_VMSISH");
2696             if (o->op_private & OPpHUSH_VMSISH)
2697                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2698         }
2699         else if (o->op_type == OP_DIE) {
2700             if (o->op_private & OPpHUSH_VMSISH)
2701                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2702         }
2703         else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2704             if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2705                 sv_catpv(tmpsv, ",FT_ACCESS");
2706             if (o->op_private & OPpFT_STACKED)
2707                 sv_catpv(tmpsv, ",FT_STACKED");
2708         }
2709         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2710             sv_catpv(tmpsv, ",INTRO");
2711         if (SvCUR(tmpsv))
2712             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2713         SvREFCNT_dec(tmpsv);
2714     }
2715
2716     switch (o->op_type) {
2717     case OP_AELEMFAST:
2718         if (o->op_flags & OPf_SPECIAL) {
2719             break;
2720         }
2721     case OP_GVSV:
2722     case OP_GV:
2723 #ifdef USE_ITHREADS
2724         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2725 #else
2726         if (cSVOPo->op_sv) {
2727             SV * const tmpsv1 = newSV(0);
2728             SV * const tmpsv2 = newSVpvn("",0);
2729             char *s;
2730             STRLEN len;
2731             SvUTF8_on(tmpsv1);
2732             SvUTF8_on(tmpsv2);
2733             ENTER;
2734             SAVEFREESV(tmpsv1);
2735             SAVEFREESV(tmpsv2);
2736             gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, Nullch);
2737             s = SvPV(tmpsv1,len);
2738             sv_catxmlpvn(tmpsv2, s, len, 1);
2739             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2740             LEAVE;
2741         }
2742         else
2743             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2744 #endif
2745         break;
2746     case OP_CONST:
2747     case OP_METHOD_NAMED:
2748 #ifndef USE_ITHREADS
2749         /* with ITHREADS, consts are stored in the pad, and the right pad
2750          * may not be active here, so skip */
2751         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2752 #endif
2753         break;
2754     case OP_ANONCODE:
2755         if (!contents) {
2756             contents = 1;
2757             PerlIO_printf(file, ">\n");
2758         }
2759         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2760         break;
2761     case OP_SETSTATE:
2762     case OP_NEXTSTATE:
2763     case OP_DBSTATE:
2764         if (CopLINE(cCOPo))
2765             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2766                              (UV)CopLINE(cCOPo));
2767         if (CopSTASHPV(cCOPo))
2768             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2769                              CopSTASHPV(cCOPo));
2770         if (cCOPo->cop_label)
2771             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2772                              cCOPo->cop_label);
2773         break;
2774     case OP_ENTERLOOP:
2775         S_xmldump_attr(aTHX_ level, file, "redo=\"");
2776         if (cLOOPo->op_redoop)
2777             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2778         else
2779             PerlIO_printf(file, "DONE\"");
2780         S_xmldump_attr(aTHX_ level, file, "next=\"");
2781         if (cLOOPo->op_nextop)
2782             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2783         else
2784             PerlIO_printf(file, "DONE\"");
2785         S_xmldump_attr(aTHX_ level, file, "last=\"");
2786         if (cLOOPo->op_lastop)
2787             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2788         else
2789             PerlIO_printf(file, "DONE\"");
2790         break;
2791     case OP_COND_EXPR:
2792     case OP_RANGE:
2793     case OP_MAPWHILE:
2794     case OP_GREPWHILE:
2795     case OP_OR:
2796     case OP_AND:
2797         S_xmldump_attr(aTHX_ level, file, "other=\"");
2798         if (cLOGOPo->op_other)
2799             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2800         else
2801             PerlIO_printf(file, "DONE\"");
2802         break;
2803     case OP_LEAVE:
2804     case OP_LEAVEEVAL:
2805     case OP_LEAVESUB:
2806     case OP_LEAVESUBLV:
2807     case OP_LEAVEWRITE:
2808     case OP_SCOPE:
2809         if (o->op_private & OPpREFCOUNTED)
2810             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2811         break;
2812     default:
2813         break;
2814     }
2815
2816     if (PL_madskills && o->op_madprop) {
2817         char prevkey = '\0';
2818         SV * const tmpsv = newSVpvn("", 0);
2819         const MADPROP* mp = o->op_madprop;
2820
2821         sv_utf8_upgrade(tmpsv);
2822         if (!contents) {
2823             contents = 1;
2824             PerlIO_printf(file, ">\n");
2825         }
2826         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2827         level++;
2828         while (mp) {
2829             char tmp = mp->mad_key;
2830             sv_setpvn(tmpsv,"\"",1);
2831             if (tmp)
2832                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2833             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2834                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2835             else
2836                 prevkey = tmp;
2837             sv_catpv(tmpsv, "\"");
2838             switch (mp->mad_type) {
2839             case MAD_NULL:
2840                 sv_catpv(tmpsv, "NULL");
2841                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2842                 break;
2843             case MAD_PV:
2844                 sv_catpv(tmpsv, " val=\"");
2845                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2846                 sv_catpv(tmpsv, "\"");
2847                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2848                 break;
2849             case MAD_SV:
2850                 sv_catpv(tmpsv, " val=\"");
2851                 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2852                 sv_catpv(tmpsv, "\"");
2853                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2854                 break;
2855             case MAD_OP:
2856                 if ((OP*)mp->mad_val) {
2857                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2858                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2859                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2860                 }
2861                 break;
2862             default:
2863                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2864                 break;
2865             }
2866             mp = mp->mad_next;
2867         }
2868         level--;
2869         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2870
2871         SvREFCNT_dec(tmpsv);
2872     }
2873
2874     switch (o->op_type) {
2875     case OP_PUSHRE:
2876     case OP_MATCH:
2877     case OP_QR:
2878     case OP_SUBST:
2879         if (!contents) {
2880             contents = 1;
2881             PerlIO_printf(file, ">\n");
2882         }
2883         do_pmop_xmldump(level, file, cPMOPo);
2884         break;
2885     default:
2886         break;
2887     }
2888
2889     if (o->op_flags & OPf_KIDS) {
2890         OP *kid;
2891         if (!contents) {
2892             contents = 1;
2893             PerlIO_printf(file, ">\n");
2894         }
2895         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2896             do_op_xmldump(level, file, kid);
2897     }
2898
2899     if (contents)
2900         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2901     else
2902         PerlIO_printf(file, " />\n");
2903 }
2904
2905 void
2906 Perl_op_xmldump(pTHX_ const OP *o)
2907 {
2908     do_op_xmldump(0, PL_xmlfp, o);
2909 }
2910 #endif
2911
2912 /*
2913  * Local variables:
2914  * c-indentation-style: bsd
2915  * c-basic-offset: 4
2916  * indent-tabs-mode: t
2917  * End:
2918  *
2919  * ex: set ts=8 sts=4 sw=4 noet:
2920  */