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