dump.c

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