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