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