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