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