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