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