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     "PV",
  36     "PVIV",
  37     "PVNV",
  38     "PVMG",
  39     "REGEXP",
  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     "PV",
  56     "PVIV",
  57     "PVNV",
  58     "PVMG",
  59     "REGEXP",
  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 && !SvROK(sv))) {
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_REGEXP) {
1594             Perl_dump_indent(aTHX_ level, file, "  REGEXP = 0x%"UVxf"\n",
1595                              PTR2UV(((struct xregexp *)SvANY(sv))->xrx_regexp));
1596     }
1597     if (type >= SVt_PVMG) {
1598         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1599             HV * const ost = SvOURSTASH(sv);
1600             if (ost)
1601                 do_hv_dump(level, file, "  OURSTASH", ost);
1602         } else {
1603             if (SvMAGIC(sv))
1604                 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1605         }
1606         if (SvSTASH(sv))
1607             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1608     }
1609     switch (type) {
1610     case SVt_PVAV:
1611         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1612         if (AvARRAY(sv) != AvALLOC(sv)) {
1613             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1614             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1615         }
1616         else
1617             PerlIO_putc(file, '\n');
1618         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1619         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1620         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1621         sv_setpvn(d, "", 0);
1622         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1623         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1624         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1625                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1626         if (nest < maxnest && av_len((AV*)sv) >= 0) {
1627             int count;
1628             for (count = 0; count <=  av_len((AV*)sv) && count < maxnest; count++) {
1629                 SV** const elt = av_fetch((AV*)sv,count,0);
1630
1631                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1632                 if (elt)
1633                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1634             }
1635         }
1636         break;
1637     case SVt_PVHV:
1638         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1639         if (HvARRAY(sv) && HvKEYS(sv)) {
1640             /* Show distribution of HEs in the ARRAY */
1641             int freq[200];
1642 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1643             int i;
1644             int max = 0;
1645             U32 pow2 = 2, keys = HvKEYS(sv);
1646             NV theoret, sum = 0;
1647
1648             PerlIO_printf(file, "  (");
1649             Zero(freq, FREQ_MAX + 1, int);
1650             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1651                 HE* h;
1652                 int count = 0;
1653                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1654                     count++;
1655                 if (count > FREQ_MAX)
1656                     count = FREQ_MAX;
1657                 freq[count]++;
1658                 if (max < count)
1659                     max = count;
1660             }
1661             for (i = 0; i <= max; i++) {
1662                 if (freq[i]) {
1663                     PerlIO_printf(file, "%d%s:%d", i,
1664                                   (i == FREQ_MAX) ? "+" : "",
1665                                   freq[i]);
1666                     if (i != max)
1667                         PerlIO_printf(file, ", ");
1668                 }
1669             }
1670             PerlIO_putc(file, ')');
1671             /* The "quality" of a hash is defined as the total number of
1672                comparisons needed to access every element once, relative
1673                to the expected number needed for a random hash.
1674
1675                The total number of comparisons is equal to the sum of
1676                the squares of the number of entries in each bucket.
1677                For a random hash of n keys into k buckets, the expected
1678                value is
1679                                 n + n(n-1)/2k
1680             */
1681
1682             for (i = max; i > 0; i--) { /* Precision: count down. */
1683                 sum += freq[i] * i * i;
1684             }
1685             while ((keys = keys >> 1))
1686                 pow2 = pow2 << 1;
1687             theoret = HvKEYS(sv);
1688             theoret += theoret * (theoret-1)/pow2;
1689             PerlIO_putc(file, '\n');
1690             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1691         }
1692         PerlIO_putc(file, '\n');
1693         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1694         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1695         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1696         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1697         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1698         {
1699             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1700             if (mg && mg->mg_obj) {
1701                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1702             }
1703         }
1704         {
1705             const char * const hvname = HvNAME_get(sv);
1706             if (hvname)
1707                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1708         }
1709         if (SvOOK(sv)) {
1710             const AV * const backrefs = *Perl_hv_backreferences_p(aTHX_ (HV*)sv);
1711             if (backrefs) {
1712                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1713                                  PTR2UV(backrefs));
1714                 do_sv_dump(level+1, file, (SV*)backrefs, nest+1, maxnest,
1715                            dumpops, pvlim);
1716             }
1717         }
1718         if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1719             HE *he;
1720             HV * const hv = (HV*)sv;
1721             int count = maxnest - nest;
1722
1723             hv_iterinit(hv);
1724             while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1725                    && count--) {
1726                 STRLEN len;
1727                 const U32 hash = HeHASH(he);
1728                 SV * const keysv = hv_iterkeysv(he);
1729                 const char * const keypv = SvPV_const(keysv, len);
1730                 SV * const elt = hv_iterval(hv, he);
1731
1732                 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1733                 if (SvUTF8(keysv))
1734                     PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1735                 if (HeKREHASH(he))
1736                     PerlIO_printf(file, "[REHASH] ");
1737                 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1738                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1739             }
1740             hv_iterinit(hv);            /* Return to status quo */
1741         }
1742         break;
1743     case SVt_PVCV:
1744         if (SvPOK(sv)) {
1745             STRLEN len;
1746             const char *const proto =  SvPV_const(sv, len);
1747             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1748                              (int) len, proto);
1749         }
1750         /* FALL THROUGH */
1751     case SVt_PVFM:
1752         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1753         if (!CvISXSUB(sv)) {
1754             if (CvSTART(sv)) {
1755                 Perl_dump_indent(aTHX_ level, file,
1756                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1757                                  PTR2UV(CvSTART(sv)),
1758                                  (IV)sequence_num(CvSTART(sv)));
1759             }
1760             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1761                              PTR2UV(CvROOT(sv)));
1762             if (CvROOT(sv) && dumpops) {
1763                 do_op_dump(level+1, file, CvROOT(sv));
1764             }
1765         } else {
1766             SV * const constant = cv_const_sv((CV *)sv);
1767
1768             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1769
1770             if (constant) {
1771                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1772                                  " (CONST SV)\n",
1773                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1774                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1775                            pvlim);
1776             } else {
1777                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1778                                  (IV)CvXSUBANY(sv).any_i32);
1779             }
1780         }
1781         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1782         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1783         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1784         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1785         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1786         if (type == SVt_PVFM)
1787             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
1788         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1789         if (nest < maxnest) {
1790             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1791         }
1792         {
1793             const CV * const outside = CvOUTSIDE(sv);
1794             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1795                         PTR2UV(outside),
1796                         (!outside ? "null"
1797                          : CvANON(outside) ? "ANON"
1798                          : (outside == PL_main_cv) ? "MAIN"
1799                          : CvUNIQUE(outside) ? "UNIQUE"
1800                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1801         }
1802         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1803             do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1804         break;
1805     case SVt_PVGV:
1806     case SVt_PVLV:
1807         if (type == SVt_PVLV) {
1808             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
1809             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1810             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1811             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1812             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1813                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1814                     dumpops, pvlim);
1815         }
1816         if (SvVALID(sv)) {
1817             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %u\n", (U8)BmFLAGS(sv));
1818             Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
1819             Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1820             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1821         }
1822         if (!isGV_with_GP(sv))
1823             break;
1824         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
1825         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1826         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
1827         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1828         if (!GvGP(sv))
1829             break;
1830         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1831         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1832         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1833         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
1834         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1835         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1836         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1837         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1838         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
1839         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
1840         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1841         do_gv_dump (level, file, "    EGV", GvEGV(sv));
1842         break;
1843     case SVt_PVIO:
1844         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1845         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1846         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1847         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
1848         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1849         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1850         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1851         if (IoTOP_NAME(sv))
1852             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1853         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1854             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
1855         else {
1856             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
1857                              PTR2UV(IoTOP_GV(sv)));
1858             do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1859                         dumpops, pvlim);
1860         }
1861         /* Source filters hide things that are not GVs in these three, so let's
1862            be careful out there.  */
1863         if (IoFMT_NAME(sv))
1864             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1865         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1866             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
1867         else {
1868             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
1869                              PTR2UV(IoFMT_GV(sv)));
1870             do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1871                         dumpops, pvlim);
1872         }
1873         if (IoBOTTOM_NAME(sv))
1874             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1875         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1876             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
1877         else {
1878             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
1879                              PTR2UV(IoBOTTOM_GV(sv)));
1880             do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1881                         dumpops, pvlim);
1882         }
1883         if (isPRINT(IoTYPE(sv)))
1884             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
1885         else
1886             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
1887         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1888         break;
1889     }
1890     SvREFCNT_dec(d);
1891 }
1892
1893 void
1894 Perl_sv_dump(pTHX_ SV *sv)
1895 {
1896     dVAR;
1897     if (SvROK(sv))
1898         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1899     else
1900         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1901 }
1902
1903 int
1904 Perl_runops_debug(pTHX)
1905 {
1906     dVAR;
1907     if (!PL_op) {
1908         if (ckWARN_d(WARN_DEBUGGING))
1909             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1910         return 0;
1911     }
1912
1913     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1914     do {
1915         PERL_ASYNC_CHECK();
1916         if (PL_debug) {
1917             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1918                 PerlIO_printf(Perl_debug_log,
1919                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1920                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1921                               PTR2UV(*PL_watchaddr));
1922             if (DEBUG_s_TEST_) {
1923                 if (DEBUG_v_TEST_) {
1924                     PerlIO_printf(Perl_debug_log, "\n");
1925                     deb_stack_all();
1926                 }
1927                 else
1928                     debstack();
1929             }
1930
1931
1932             if (DEBUG_t_TEST_) debop(PL_op);
1933             if (DEBUG_P_TEST_) debprof(PL_op);
1934         }
1935     } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1936     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1937
1938     TAINT_NOT;
1939     return 0;
1940 }
1941
1942 I32
1943 Perl_debop(pTHX_ const OP *o)
1944 {
1945     dVAR;
1946     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1947         return 0;
1948
1949     Perl_deb(aTHX_ "%s", OP_NAME(o));
1950     switch (o->op_type) {
1951     case OP_CONST:
1952         PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1953         break;
1954     case OP_GVSV:
1955     case OP_GV:
1956         if (cGVOPo_gv) {
1957             SV * const sv = newSV(0);
1958 #ifdef PERL_MAD
1959             /* FIXME - is this making unwarranted assumptions about the
1960                UTF-8 cleanliness of the dump file handle?  */
1961             SvUTF8_on(sv);
1962 #endif
1963             gv_fullname3(sv, cGVOPo_gv, NULL);
1964             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1965             SvREFCNT_dec(sv);
1966         }
1967         else
1968             PerlIO_printf(Perl_debug_log, "(NULL)");
1969         break;
1970     case OP_PADSV:
1971     case OP_PADAV:
1972     case OP_PADHV:
1973         {
1974         /* print the lexical's name */
1975         CV * const cv = deb_curcv(cxstack_ix);
1976         SV *sv;
1977         if (cv) {
1978             AV * const padlist = CvPADLIST(cv);
1979             AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1980             sv = *av_fetch(comppad, o->op_targ, FALSE);
1981         } else
1982             sv = NULL;
1983         if (sv)
1984             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1985         else
1986             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1987         }
1988         break;
1989     default:
1990         break;
1991     }
1992     PerlIO_printf(Perl_debug_log, "\n");
1993     return 0;
1994 }
1995
1996 STATIC CV*
1997 S_deb_curcv(pTHX_ const I32 ix)
1998 {
1999     dVAR;
2000     const PERL_CONTEXT * const cx = &cxstack[ix];
2001     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2002         return cx->blk_sub.cv;
2003     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2004         return PL_compcv;
2005     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2006         return PL_main_cv;
2007     else if (ix <= 0)
2008         return NULL;
2009     else
2010         return deb_curcv(ix - 1);
2011 }
2012
2013 void
2014 Perl_watch(pTHX_ char **addr)
2015 {
2016     dVAR;
2017     PL_watchaddr = addr;
2018     PL_watchok = *addr;
2019     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2020         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2021 }
2022
2023 STATIC void
2024 S_debprof(pTHX_ const OP *o)
2025 {
2026     dVAR;
2027     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2028         return;
2029     if (!PL_profiledata)
2030         Newxz(PL_profiledata, MAXO, U32);
2031     ++PL_profiledata[o->op_type];
2032 }
2033
2034 void
2035 Perl_debprofdump(pTHX)
2036 {
2037     dVAR;
2038     unsigned i;
2039     if (!PL_profiledata)
2040         return;
2041     for (i = 0; i < MAXO; i++) {
2042         if (PL_profiledata[i])
2043             PerlIO_printf(Perl_debug_log,
2044                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2045                                        PL_op_name[i]);
2046     }
2047 }
2048
2049 #ifdef PERL_MAD
2050 /*
2051  *    XML variants of most of the above routines
2052  */
2053
2054 STATIC void
2055 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2056 {
2057     va_list args;
2058     PerlIO_printf(file, "\n    ");
2059     va_start(args, pat);
2060     xmldump_vindent(level, file, pat, &args);
2061     va_end(args);
2062 }
2063
2064
2065 void
2066 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2067 {
2068     va_list args;
2069     va_start(args, pat);
2070     xmldump_vindent(level, file, pat, &args);
2071     va_end(args);
2072 }
2073
2074 void
2075 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2076 {
2077     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2078     PerlIO_vprintf(file, pat, *args);
2079 }
2080
2081 void
2082 Perl_xmldump_all(pTHX)
2083 {
2084     PerlIO_setlinebuf(PL_xmlfp);
2085     if (PL_main_root)
2086         op_xmldump(PL_main_root);
2087     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2088         PerlIO_close(PL_xmlfp);
2089     PL_xmlfp = 0;
2090 }
2091
2092 void
2093 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2094 {
2095     I32 i;
2096     HE  *entry;
2097
2098     if (!HvARRAY(stash))
2099         return;
2100     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2101         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2102             GV *gv = (GV*)HeVAL(entry);
2103             HV *hv;
2104             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2105                 continue;
2106             if (GvCVu(gv))
2107                 xmldump_sub(gv);
2108             if (GvFORM(gv))
2109                 xmldump_form(gv);
2110             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2111                 && (hv = GvHV(gv)) && hv != PL_defstash)
2112                 xmldump_packsubs(hv);           /* nested package */
2113         }
2114     }
2115 }
2116
2117 void
2118 Perl_xmldump_sub(pTHX_ const GV *gv)
2119 {
2120     SV * const sv = sv_newmortal();
2121
2122     gv_fullname3(sv, gv, NULL);
2123     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2124     if (CvXSUB(GvCV(gv)))
2125         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2126             PTR2UV(CvXSUB(GvCV(gv))),
2127             (int)CvXSUBANY(GvCV(gv)).any_i32);
2128     else if (CvROOT(GvCV(gv)))
2129         op_xmldump(CvROOT(GvCV(gv)));
2130     else
2131         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2132 }
2133
2134 void
2135 Perl_xmldump_form(pTHX_ const GV *gv)
2136 {
2137     SV * const sv = sv_newmortal();
2138
2139     gv_fullname3(sv, gv, NULL);
2140     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2141     if (CvROOT(GvFORM(gv)))
2142         op_xmldump(CvROOT(GvFORM(gv)));
2143     else
2144         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2145 }
2146
2147 void
2148 Perl_xmldump_eval(pTHX)
2149 {
2150     op_xmldump(PL_eval_root);
2151 }
2152
2153 char *
2154 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2155 {
2156     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2157 }
2158
2159 char *
2160 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2161 {
2162     unsigned int c;
2163     const char * const e = pv + len;
2164     const char * const start = pv;
2165     STRLEN dsvcur;
2166     STRLEN cl;
2167
2168     sv_catpvn(dsv,"",0);
2169     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2170
2171   retry:
2172     while (pv < e) {
2173         if (utf8) {
2174             c = utf8_to_uvchr((U8*)pv, &cl);
2175             if (cl == 0) {
2176                 SvCUR(dsv) = dsvcur;
2177                 pv = start;
2178                 utf8 = 0;
2179                 goto retry;
2180             }
2181         }
2182         else
2183             c = (*pv & 255);
2184
2185         switch (c) {
2186         case 0x00:
2187         case 0x01:
2188         case 0x02:
2189         case 0x03:
2190         case 0x04:
2191         case 0x05:
2192         case 0x06:
2193         case 0x07:
2194         case 0x08:
2195         case 0x0b:
2196         case 0x0c:
2197         case 0x0e:
2198         case 0x0f:
2199         case 0x10:
2200         case 0x11:
2201         case 0x12:
2202         case 0x13:
2203         case 0x14:
2204         case 0x15:
2205         case 0x16:
2206         case 0x17:
2207         case 0x18:
2208         case 0x19:
2209         case 0x1a:
2210         case 0x1b:
2211         case 0x1c:
2212         case 0x1d:
2213         case 0x1e:
2214         case 0x1f:
2215         case 0x7f:
2216         case 0x80:
2217         case 0x81:
2218         case 0x82:
2219         case 0x83:
2220         case 0x84:
2221         case 0x86:
2222         case 0x87:
2223         case 0x88:
2224         case 0x89:
2225         case 0x90:
2226         case 0x91:
2227         case 0x92:
2228         case 0x93:
2229         case 0x94:
2230         case 0x95:
2231         case 0x96:
2232         case 0x97:
2233         case 0x98:
2234         case 0x99:
2235         case 0x9a:
2236         case 0x9b:
2237         case 0x9c:
2238         case 0x9d:
2239         case 0x9e:
2240         case 0x9f:
2241             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2242             break;
2243         case '<':
2244             sv_catpvs(dsv, "&lt;");
2245             break;
2246         case '>':
2247             sv_catpvs(dsv, "&gt;");
2248             break;
2249         case '&':
2250             sv_catpvs(dsv, "&amp;");
2251             break;
2252         case '"':
2253             sv_catpvs(dsv, "&#34;");
2254             break;
2255         default:
2256             if (c < 0xD800) {
2257                 if (c < 32 || c > 127) {
2258                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2259                 }
2260                 else {
2261                     const char string = (char) c;
2262                     sv_catpvn(dsv, &string, 1);
2263                 }
2264                 break;
2265             }
2266             if ((c >= 0xD800 && c <= 0xDB7F) ||
2267                 (c >= 0xDC00 && c <= 0xDFFF) ||
2268                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2269                  c > 0x10ffff)
2270                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2271             else
2272                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2273         }
2274
2275         if (utf8)
2276             pv += UTF8SKIP(pv);
2277         else
2278             pv++;
2279     }
2280
2281     return SvPVX(dsv);
2282 }
2283
2284 char *
2285 Perl_sv_xmlpeek(pTHX_ SV *sv)
2286 {
2287     SV * const t = sv_newmortal();
2288     STRLEN n_a;
2289     int unref = 0;
2290
2291     sv_utf8_upgrade(t);
2292     sv_setpvn(t, "", 0);
2293     /* retry: */
2294     if (!sv) {
2295         sv_catpv(t, "VOID=\"\"");
2296         goto finish;
2297     }
2298     else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2299         sv_catpv(t, "WILD=\"\"");
2300         goto finish;
2301     }
2302     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2303         if (sv == &PL_sv_undef) {
2304             sv_catpv(t, "SV_UNDEF=\"1\"");
2305             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2306                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2307                 SvREADONLY(sv))
2308                 goto finish;
2309         }
2310         else if (sv == &PL_sv_no) {
2311             sv_catpv(t, "SV_NO=\"1\"");
2312             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2313                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2314                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2315                                   SVp_POK|SVp_NOK)) &&
2316                 SvCUR(sv) == 0 &&
2317                 SvNVX(sv) == 0.0)
2318                 goto finish;
2319         }
2320         else if (sv == &PL_sv_yes) {
2321             sv_catpv(t, "SV_YES=\"1\"");
2322             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2323                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2324                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2325                                   SVp_POK|SVp_NOK)) &&
2326                 SvCUR(sv) == 1 &&
2327                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2328                 SvNVX(sv) == 1.0)
2329                 goto finish;
2330         }
2331         else {
2332             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2333             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2334                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2335                 SvREADONLY(sv))
2336                 goto finish;
2337         }
2338         sv_catpv(t, " XXX=\"\" ");
2339     }
2340     else if (SvREFCNT(sv) == 0) {
2341         sv_catpv(t, " refcnt=\"0\"");
2342         unref++;
2343     }
2344     else if (DEBUG_R_TEST_) {
2345         int is_tmp = 0;
2346         I32 ix;
2347         /* is this SV on the tmps stack? */
2348         for (ix=PL_tmps_ix; ix>=0; ix--) {
2349             if (PL_tmps_stack[ix] == sv) {
2350                 is_tmp = 1;
2351                 break;
2352             }
2353         }
2354         if (SvREFCNT(sv) > 1)
2355             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2356                     is_tmp ? "T" : "");
2357         else if (is_tmp)
2358             sv_catpv(t, " DRT=\"<T>\"");
2359     }
2360
2361     if (SvROK(sv)) {
2362         sv_catpv(t, " ROK=\"\"");
2363     }
2364     switch (SvTYPE(sv)) {
2365     default:
2366         sv_catpv(t, " FREED=\"1\"");
2367         goto finish;
2368
2369     case SVt_NULL:
2370         sv_catpv(t, " UNDEF=\"1\"");
2371         goto finish;
2372     case SVt_IV:
2373         sv_catpv(t, " IV=\"");
2374         break;
2375     case SVt_NV:
2376         sv_catpv(t, " NV=\"");
2377         break;
2378     case SVt_PV:
2379         sv_catpv(t, " PV=\"");
2380         break;
2381     case SVt_PVIV:
2382         sv_catpv(t, " PVIV=\"");
2383         break;
2384     case SVt_PVNV:
2385         sv_catpv(t, " PVNV=\"");
2386         break;
2387     case SVt_PVMG:
2388         sv_catpv(t, " PVMG=\"");
2389         break;
2390     case SVt_PVLV:
2391         sv_catpv(t, " PVLV=\"");
2392         break;
2393     case SVt_PVAV:
2394         sv_catpv(t, " AV=\"");
2395         break;
2396     case SVt_PVHV:
2397         sv_catpv(t, " HV=\"");
2398         break;
2399     case SVt_PVCV:
2400         if (CvGV(sv))
2401             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2402         else
2403             sv_catpv(t, " CV=\"()\"");
2404         goto finish;
2405     case SVt_PVGV:
2406         sv_catpv(t, " GV=\"");
2407         break;
2408     case SVt_BIND:
2409         sv_catpv(t, " BIND=\"");
2410         break;
2411     case SVt_ORANGE:
2412         sv_catpv(t, " ORANGE=\"");
2413         break;
2414     case SVt_PVFM:
2415         sv_catpv(t, " FM=\"");
2416         break;
2417     case SVt_PVIO:
2418         sv_catpv(t, " IO=\"");
2419         break;
2420     }
2421
2422     if (SvPOKp(sv)) {
2423         if (SvPVX(sv)) {
2424             sv_catxmlsv(t, sv);
2425         }
2426     }
2427     else if (SvNOKp(sv)) {
2428         STORE_NUMERIC_LOCAL_SET_STANDARD();
2429         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2430         RESTORE_NUMERIC_LOCAL();
2431     }
2432     else if (SvIOKp(sv)) {
2433         if (SvIsUV(sv))
2434             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2435         else
2436             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2437     }
2438     else
2439         sv_catpv(t, "");
2440     sv_catpv(t, "\"");
2441
2442   finish:
2443     while (unref--)
2444         sv_catpv(t, ")");
2445     return SvPV(t, n_a);
2446 }
2447
2448 void
2449 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2450 {
2451     if (!pm) {
2452         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2453         return;
2454     }
2455     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2456     level++;
2457     if (PM_GETRE(pm)) {
2458         const regexp *const r = PM_GETRE(pm);
2459         SV * const tmpsv = newSVpvn(r->precomp,r->prelen);
2460         SvUTF8_on(tmpsv);
2461         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2462              SvPVX(tmpsv));
2463         SvREFCNT_dec(tmpsv);
2464         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2465              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2466     }
2467     else
2468         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2469     if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
2470         SV * const tmpsv = pm_description(pm);
2471         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2472         SvREFCNT_dec(tmpsv);
2473     }
2474
2475     level--;
2476     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2477         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2478         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2479         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2480         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2481         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2482     }
2483     else
2484         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2485 }
2486
2487 void
2488 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2489 {
2490     do_pmop_xmldump(0, PL_xmlfp, pm);
2491 }
2492
2493 void
2494 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2495 {
2496     UV      seq;
2497     int     contents = 0;
2498     if (!o)
2499         return;
2500     sequence(o);
2501     seq = sequence_num(o);
2502     Perl_xmldump_indent(aTHX_ level, file,
2503         "<op_%s seq=\"%"UVuf" -> ",
2504              OP_NAME(o),
2505                       seq);
2506     level++;
2507     if (o->op_next)
2508         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2509                       sequence_num(o->op_next));
2510     else
2511         PerlIO_printf(file, "DONE\"");
2512
2513     if (o->op_targ) {
2514         if (o->op_type == OP_NULL)
2515         {
2516             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2517             if (o->op_targ == OP_NEXTSTATE)
2518             {
2519                 if (CopLINE(cCOPo))
2520                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2521                                      (UV)CopLINE(cCOPo));
2522                 if (CopSTASHPV(cCOPo))
2523                     PerlIO_printf(file, " package=\"%s\"",
2524                                      CopSTASHPV(cCOPo));
2525                 if (cCOPo->cop_label)
2526                     PerlIO_printf(file, " label=\"%s\"",
2527                                      cCOPo->cop_label);
2528             }
2529         }
2530         else
2531             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2532     }
2533 #ifdef DUMPADDR
2534     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2535 #endif
2536     if (o->op_flags) {
2537         SV * const tmpsv = newSVpvn("", 0);
2538         switch (o->op_flags & OPf_WANT) {
2539         case OPf_WANT_VOID:
2540             sv_catpv(tmpsv, ",VOID");
2541             break;
2542         case OPf_WANT_SCALAR:
2543             sv_catpv(tmpsv, ",SCALAR");
2544             break;
2545         case OPf_WANT_LIST:
2546             sv_catpv(tmpsv, ",LIST");
2547             break;
2548         default:
2549             sv_catpv(tmpsv, ",UNKNOWN");
2550             break;
2551         }
2552         if (o->op_flags & OPf_KIDS)
2553             sv_catpv(tmpsv, ",KIDS");
2554         if (o->op_flags & OPf_PARENS)
2555             sv_catpv(tmpsv, ",PARENS");
2556         if (o->op_flags & OPf_STACKED)
2557             sv_catpv(tmpsv, ",STACKED");
2558         if (o->op_flags & OPf_REF)
2559             sv_catpv(tmpsv, ",REF");
2560         if (o->op_flags & OPf_MOD)
2561             sv_catpv(tmpsv, ",MOD");
2562         if (o->op_flags & OPf_SPECIAL)
2563             sv_catpv(tmpsv, ",SPECIAL");
2564         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2565         SvREFCNT_dec(tmpsv);
2566     }
2567     if (o->op_private) {
2568         SV * const tmpsv = newSVpvn("", 0);
2569         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2570             if (o->op_private & OPpTARGET_MY)
2571                 sv_catpv(tmpsv, ",TARGET_MY");
2572         }
2573         else if (o->op_type == OP_LEAVESUB ||
2574                  o->op_type == OP_LEAVE ||
2575                  o->op_type == OP_LEAVESUBLV ||
2576                  o->op_type == OP_LEAVEWRITE) {
2577             if (o->op_private & OPpREFCOUNTED)
2578                 sv_catpv(tmpsv, ",REFCOUNTED");
2579         }
2580         else if (o->op_type == OP_AASSIGN) {
2581             if (o->op_private & OPpASSIGN_COMMON)
2582                 sv_catpv(tmpsv, ",COMMON");
2583         }
2584         else if (o->op_type == OP_SASSIGN) {
2585             if (o->op_private & OPpASSIGN_BACKWARDS)
2586                 sv_catpv(tmpsv, ",BACKWARDS");
2587         }
2588         else if (o->op_type == OP_TRANS) {
2589             if (o->op_private & OPpTRANS_SQUASH)
2590                 sv_catpv(tmpsv, ",SQUASH");
2591             if (o->op_private & OPpTRANS_DELETE)
2592                 sv_catpv(tmpsv, ",DELETE");
2593             if (o->op_private & OPpTRANS_COMPLEMENT)
2594                 sv_catpv(tmpsv, ",COMPLEMENT");
2595             if (o->op_private & OPpTRANS_IDENTICAL)
2596                 sv_catpv(tmpsv, ",IDENTICAL");
2597             if (o->op_private & OPpTRANS_GROWS)
2598                 sv_catpv(tmpsv, ",GROWS");
2599         }
2600         else if (o->op_type == OP_REPEAT) {
2601             if (o->op_private & OPpREPEAT_DOLIST)
2602                 sv_catpv(tmpsv, ",DOLIST");
2603         }
2604         else if (o->op_type == OP_ENTERSUB ||
2605                  o->op_type == OP_RV2SV ||
2606                  o->op_type == OP_GVSV ||
2607                  o->op_type == OP_RV2AV ||
2608                  o->op_type == OP_RV2HV ||
2609                  o->op_type == OP_RV2GV ||
2610                  o->op_type == OP_AELEM ||
2611                  o->op_type == OP_HELEM )
2612         {
2613             if (o->op_type == OP_ENTERSUB) {
2614                 if (o->op_private & OPpENTERSUB_AMPER)
2615                     sv_catpv(tmpsv, ",AMPER");
2616                 if (o->op_private & OPpENTERSUB_DB)
2617                     sv_catpv(tmpsv, ",DB");
2618                 if (o->op_private & OPpENTERSUB_HASTARG)
2619                     sv_catpv(tmpsv, ",HASTARG");
2620                 if (o->op_private & OPpENTERSUB_NOPAREN)
2621                     sv_catpv(tmpsv, ",NOPAREN");
2622                 if (o->op_private & OPpENTERSUB_INARGS)
2623                     sv_catpv(tmpsv, ",INARGS");
2624                 if (o->op_private & OPpENTERSUB_NOMOD)
2625                     sv_catpv(tmpsv, ",NOMOD");
2626             }
2627             else {
2628                 switch (o->op_private & OPpDEREF) {
2629             case OPpDEREF_SV:
2630                 sv_catpv(tmpsv, ",SV");
2631                 break;
2632             case OPpDEREF_AV:
2633                 sv_catpv(tmpsv, ",AV");
2634                 break;
2635             case OPpDEREF_HV:
2636                 sv_catpv(tmpsv, ",HV");
2637                 break;
2638             }
2639                 if (o->op_private & OPpMAYBE_LVSUB)
2640                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2641             }
2642             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2643                 if (o->op_private & OPpLVAL_DEFER)
2644                     sv_catpv(tmpsv, ",LVAL_DEFER");
2645             }
2646             else {
2647                 if (o->op_private & HINT_STRICT_REFS)
2648                     sv_catpv(tmpsv, ",STRICT_REFS");
2649                 if (o->op_private & OPpOUR_INTRO)
2650                     sv_catpv(tmpsv, ",OUR_INTRO");
2651             }
2652         }
2653         else if (o->op_type == OP_CONST) {
2654             if (o->op_private & OPpCONST_BARE)
2655                 sv_catpv(tmpsv, ",BARE");
2656             if (o->op_private & OPpCONST_STRICT)
2657                 sv_catpv(tmpsv, ",STRICT");
2658             if (o->op_private & OPpCONST_ARYBASE)
2659                 sv_catpv(tmpsv, ",ARYBASE");
2660             if (o->op_private & OPpCONST_WARNING)
2661                 sv_catpv(tmpsv, ",WARNING");
2662             if (o->op_private & OPpCONST_ENTERED)
2663                 sv_catpv(tmpsv, ",ENTERED");
2664         }
2665         else if (o->op_type == OP_FLIP) {
2666             if (o->op_private & OPpFLIP_LINENUM)
2667                 sv_catpv(tmpsv, ",LINENUM");
2668         }
2669         else if (o->op_type == OP_FLOP) {
2670             if (o->op_private & OPpFLIP_LINENUM)
2671                 sv_catpv(tmpsv, ",LINENUM");
2672         }
2673         else if (o->op_type == OP_RV2CV) {
2674             if (o->op_private & OPpLVAL_INTRO)
2675                 sv_catpv(tmpsv, ",INTRO");
2676         }
2677         else if (o->op_type == OP_GV) {
2678             if (o->op_private & OPpEARLY_CV)
2679                 sv_catpv(tmpsv, ",EARLY_CV");
2680         }
2681         else if (o->op_type == OP_LIST) {
2682             if (o->op_private & OPpLIST_GUESSED)
2683                 sv_catpv(tmpsv, ",GUESSED");
2684         }
2685         else if (o->op_type == OP_DELETE) {
2686             if (o->op_private & OPpSLICE)
2687                 sv_catpv(tmpsv, ",SLICE");
2688         }
2689         else if (o->op_type == OP_EXISTS) {
2690             if (o->op_private & OPpEXISTS_SUB)
2691                 sv_catpv(tmpsv, ",EXISTS_SUB");
2692         }
2693         else if (o->op_type == OP_SORT) {
2694             if (o->op_private & OPpSORT_NUMERIC)
2695                 sv_catpv(tmpsv, ",NUMERIC");
2696             if (o->op_private & OPpSORT_INTEGER)
2697                 sv_catpv(tmpsv, ",INTEGER");
2698             if (o->op_private & OPpSORT_REVERSE)
2699                 sv_catpv(tmpsv, ",REVERSE");
2700         }
2701         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2702             if (o->op_private & OPpOPEN_IN_RAW)
2703                 sv_catpv(tmpsv, ",IN_RAW");
2704             if (o->op_private & OPpOPEN_IN_CRLF)
2705                 sv_catpv(tmpsv, ",IN_CRLF");
2706             if (o->op_private & OPpOPEN_OUT_RAW)
2707                 sv_catpv(tmpsv, ",OUT_RAW");
2708             if (o->op_private & OPpOPEN_OUT_CRLF)
2709                 sv_catpv(tmpsv, ",OUT_CRLF");
2710         }
2711         else if (o->op_type == OP_EXIT) {
2712             if (o->op_private & OPpEXIT_VMSISH)
2713                 sv_catpv(tmpsv, ",EXIT_VMSISH");
2714             if (o->op_private & OPpHUSH_VMSISH)
2715                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2716         }
2717         else if (o->op_type == OP_DIE) {
2718             if (o->op_private & OPpHUSH_VMSISH)
2719                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2720         }
2721         else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2722             if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
2723                 sv_catpv(tmpsv, ",FT_ACCESS");
2724             if (o->op_private & OPpFT_STACKED)
2725                 sv_catpv(tmpsv, ",FT_STACKED");
2726         }
2727         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2728             sv_catpv(tmpsv, ",INTRO");
2729         if (SvCUR(tmpsv))
2730             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2731         SvREFCNT_dec(tmpsv);
2732     }
2733
2734     switch (o->op_type) {
2735     case OP_AELEMFAST:
2736         if (o->op_flags & OPf_SPECIAL) {
2737             break;
2738         }
2739     case OP_GVSV:
2740     case OP_GV:
2741 #ifdef USE_ITHREADS
2742         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2743 #else
2744         if (cSVOPo->op_sv) {
2745             SV * const tmpsv1 = newSV(0);
2746             SV * const tmpsv2 = newSVpvn("",0);
2747             char *s;
2748             STRLEN len;
2749             SvUTF8_on(tmpsv1);
2750             SvUTF8_on(tmpsv2);
2751             ENTER;
2752             SAVEFREESV(tmpsv1);
2753             SAVEFREESV(tmpsv2);
2754             gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
2755             s = SvPV(tmpsv1,len);
2756             sv_catxmlpvn(tmpsv2, s, len, 1);
2757             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2758             LEAVE;
2759         }
2760         else
2761             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2762 #endif
2763         break;
2764     case OP_CONST:
2765     case OP_METHOD_NAMED:
2766 #ifndef USE_ITHREADS
2767         /* with ITHREADS, consts are stored in the pad, and the right pad
2768          * may not be active here, so skip */
2769         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2770 #endif
2771         break;
2772     case OP_ANONCODE:
2773         if (!contents) {
2774             contents = 1;
2775             PerlIO_printf(file, ">\n");
2776         }
2777         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2778         break;
2779     case OP_SETSTATE:
2780     case OP_NEXTSTATE:
2781     case OP_DBSTATE:
2782         if (CopLINE(cCOPo))
2783             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2784                              (UV)CopLINE(cCOPo));
2785         if (CopSTASHPV(cCOPo))
2786             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2787                              CopSTASHPV(cCOPo));
2788         if (cCOPo->cop_label)
2789             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2790                              cCOPo->cop_label);
2791         break;
2792     case OP_ENTERLOOP:
2793         S_xmldump_attr(aTHX_ level, file, "redo=\"");
2794         if (cLOOPo->op_redoop)
2795             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2796         else
2797             PerlIO_printf(file, "DONE\"");
2798         S_xmldump_attr(aTHX_ level, file, "next=\"");
2799         if (cLOOPo->op_nextop)
2800             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2801         else
2802             PerlIO_printf(file, "DONE\"");
2803         S_xmldump_attr(aTHX_ level, file, "last=\"");
2804         if (cLOOPo->op_lastop)
2805             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2806         else
2807             PerlIO_printf(file, "DONE\"");
2808         break;
2809     case OP_COND_EXPR:
2810     case OP_RANGE:
2811     case OP_MAPWHILE:
2812     case OP_GREPWHILE:
2813     case OP_OR:
2814     case OP_AND:
2815         S_xmldump_attr(aTHX_ level, file, "other=\"");
2816         if (cLOGOPo->op_other)
2817             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2818         else
2819             PerlIO_printf(file, "DONE\"");
2820         break;
2821     case OP_LEAVE:
2822     case OP_LEAVEEVAL:
2823     case OP_LEAVESUB:
2824     case OP_LEAVESUBLV:
2825     case OP_LEAVEWRITE:
2826     case OP_SCOPE:
2827         if (o->op_private & OPpREFCOUNTED)
2828             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2829         break;
2830     default:
2831         break;
2832     }
2833
2834     if (PL_madskills && o->op_madprop) {
2835         char prevkey = '\0';
2836         SV * const tmpsv = newSVpvn("", 0);
2837         const MADPROP* mp = o->op_madprop;
2838
2839         sv_utf8_upgrade(tmpsv);
2840         if (!contents) {
2841             contents = 1;
2842             PerlIO_printf(file, ">\n");
2843         }
2844         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2845         level++;
2846         while (mp) {
2847             char tmp = mp->mad_key;
2848             sv_setpvn(tmpsv,"\"",1);
2849             if (tmp)
2850                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2851             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2852                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2853             else
2854                 prevkey = tmp;
2855             sv_catpv(tmpsv, "\"");
2856             switch (mp->mad_type) {
2857             case MAD_NULL:
2858                 sv_catpv(tmpsv, "NULL");
2859                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2860                 break;
2861             case MAD_PV:
2862                 sv_catpv(tmpsv, " val=\"");
2863                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2864                 sv_catpv(tmpsv, "\"");
2865                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2866                 break;
2867             case MAD_SV:
2868                 sv_catpv(tmpsv, " val=\"");
2869                 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2870                 sv_catpv(tmpsv, "\"");
2871                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2872                 break;
2873             case MAD_OP:
2874                 if ((OP*)mp->mad_val) {
2875                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2876                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2877                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2878                 }
2879                 break;
2880             default:
2881                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2882                 break;
2883             }
2884             mp = mp->mad_next;
2885         }
2886         level--;
2887         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2888
2889         SvREFCNT_dec(tmpsv);
2890     }
2891
2892     switch (o->op_type) {
2893     case OP_PUSHRE:
2894     case OP_MATCH:
2895     case OP_QR:
2896     case OP_SUBST:
2897         if (!contents) {
2898             contents = 1;
2899             PerlIO_printf(file, ">\n");
2900         }
2901         do_pmop_xmldump(level, file, cPMOPo);
2902         break;
2903     default:
2904         break;
2905     }
2906
2907     if (o->op_flags & OPf_KIDS) {
2908         OP *kid;
2909         if (!contents) {
2910             contents = 1;
2911             PerlIO_printf(file, ">\n");
2912         }
2913         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2914             do_op_xmldump(level, file, kid);
2915     }
2916
2917     if (contents)
2918         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
2919     else
2920         PerlIO_printf(file, " />\n");
2921 }
2922
2923 void
2924 Perl_op_xmldump(pTHX_ const OP *o)
2925 {
2926     do_op_xmldump(0, PL_xmlfp, o);
2927 }
2928 #endif
2929
2930 /*
2931  * Local variables:
2932  * c-indentation-style: bsd
2933  * c-basic-offset: 4
2934  * indent-tabs-mode: t
2935  * End:
2936  *
2937  * ex: set ts=8 sts=4 sw=4 noet:
2938  */