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