dump.c

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