dump.c

   1 /*    dump.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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  *     [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
  16  */
  17
  18 /* This file contains utility routines to dump the contents of SV and OP
  19  * structures, as used by command-line options like -Dt and -Dx, and
  20  * by Devel::Peek.
  21  *
  22  * It also holds the debugging version of the  runops function.
  23  */
  24
  25 #include "EXTERN.h"
  26 #define PERL_IN_DUMP_C
  27 #include "perl.h"
  28 #include "regcomp.h"
  29 #include "proto.h"
  30
  31
  32 static const char* const svtypenames[SVt_LAST] = {
  33     "NULL",
  34     "BIND",
  35     "IV",
  36     "NV",
  37     "PV",
  38     "PVIV",
  39     "PVNV",
  40     "PVMG",
  41     "REGEXP",
  42     "PVGV",
  43     "PVLV",
  44     "PVAV",
  45     "PVHV",
  46     "PVCV",
  47     "PVFM",
  48     "PVIO"
  49 };
  50
  51
  52 static const char* const svshorttypenames[SVt_LAST] = {
  53     "UNDEF",
  54     "BIND",
  55     "IV",
  56     "NV",
  57     "PV",
  58     "PVIV",
  59     "PVNV",
  60     "PVMG",
  61     "REGEXP",
  62     "GV",
  63     "PVLV",
  64     "AV",
  65     "HV",
  66     "CV",
  67     "FM",
  68     "IO"
  69 };
  70
  71 struct flag_to_name {
  72     U32 flag;
  73     const char *name;
  74 };
  75
  76 static void
  77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
  78                const struct flag_to_name *const end)
  79 {
  80     do {
  81         if (flags & start->flag)
  82             sv_catpv(sv, start->name);
  83     } while (++start < end);
  84 }
  85
  86 #define append_flags(sv, f, flags) \
  87     S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
  88
  89
  90 #define Sequence PL_op_sequence
  91
  92 void
  93 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
  94 {
  95     va_list args;
  96     PERL_ARGS_ASSERT_DUMP_INDENT;
  97     va_start(args, pat);
  98     dump_vindent(level, file, pat, &args);
  99     va_end(args);
 100 }
 101
 102 void
 103 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
 104 {
 105     dVAR;
 106     PERL_ARGS_ASSERT_DUMP_VINDENT;
 107     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
 108     PerlIO_vprintf(file, pat, *args);
 109 }
 110
 111 void
 112 Perl_dump_all(pTHX)
 113 {
 114     dump_all_perl(FALSE);
 115 }
 116
 117 void
 118 Perl_dump_all_perl(pTHX_ bool justperl)
 119 {
 120
 121     dVAR;
 122     PerlIO_setlinebuf(Perl_debug_log);
 123     if (PL_main_root)
 124         op_dump(PL_main_root);
 125     dump_packsubs_perl(PL_defstash, justperl);
 126 }
 127
 128 void
 129 Perl_dump_packsubs(pTHX_ const HV *stash)
 130 {
 131     PERL_ARGS_ASSERT_DUMP_PACKSUBS;
 132     dump_packsubs_perl(stash, FALSE);
 133 }
 134
 135 void
 136 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
 137 {
 138     dVAR;
 139     I32 i;
 140
 141     PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
 142
 143     if (!HvARRAY(stash))
 144         return;
 145     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 146         const HE *entry;
 147         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 148             const GV * const gv = (const GV *)HeVAL(entry);
 149             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 150                 continue;
 151             if (GvCVu(gv))
 152                 dump_sub_perl(gv, justperl);
 153             if (GvFORM(gv))
 154                 dump_form(gv);
 155             if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
 156                 const HV * const hv = GvHV(gv);
 157                 if (hv && (hv != PL_defstash))
 158                     dump_packsubs_perl(hv, justperl); /* nested package */
 159             }
 160         }
 161     }
 162 }
 163
 164 void
 165 Perl_dump_sub(pTHX_ const GV *gv)
 166 {
 167     PERL_ARGS_ASSERT_DUMP_SUB;
 168     dump_sub_perl(gv, FALSE);
 169 }
 170
 171 void
 172 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
 173 {
 174     SV * sv;
 175
 176     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
 177
 178     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
 179         return;
 180
 181     sv = sv_newmortal();
 182     gv_fullname3(sv, gv, NULL);
 183     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
 184     if (CvISXSUB(GvCV(gv)))
 185         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
 186             PTR2UV(CvXSUB(GvCV(gv))),
 187             (int)CvXSUBANY(GvCV(gv)).any_i32);
 188     else if (CvROOT(GvCV(gv)))
 189         op_dump(CvROOT(GvCV(gv)));
 190     else
 191         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 192 }
 193
 194 void
 195 Perl_dump_form(pTHX_ const GV *gv)
 196 {
 197     SV * const sv = sv_newmortal();
 198
 199     PERL_ARGS_ASSERT_DUMP_FORM;
 200
 201     gv_fullname3(sv, gv, NULL);
 202     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
 203     if (CvROOT(GvFORM(gv)))
 204         op_dump(CvROOT(GvFORM(gv)));
 205     else
 206         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 207 }
 208
 209 void
 210 Perl_dump_eval(pTHX)
 211 {
 212     dVAR;
 213     op_dump(PL_eval_root);
 214 }
 215
 216
 217 /*
 218 =for apidoc pv_escape
 219
 220 Escapes at most the first "count" chars of pv and puts the results into
 221 dsv such that the size of the escaped string will not exceed "max" chars
 222 and will not contain any incomplete escape sequences.
 223
 224 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
 225 will also be escaped.
 226
 227 Normally the SV will be cleared before the escaped string is prepared,
 228 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
 229
 230 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode,
 231 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
 232 using C<is_utf8_string()> to determine if it is Unicode.
 233
 234 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
 235 using C<\x01F1> style escapes, otherwise if PERL_PV_ESCAPE_NONASCII is set, only
 236 chars above 127 will be escaped using this style; otherwise, only chars above
 237 255 will be so escaped; other non printable chars will use octal or
 238 common escaped patterns like C<\n>. Otherwise, if PERL_PV_ESCAPE_NOBACKSLASH
 239 then all chars below 255 will be treated as printable and
 240 will be output as literals.
 241
 242 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
 243 string will be escaped, regardless of max. If the output is to be in hex,
 244 then it will be returned as a plain hex
 245 sequence. Thus the output will either be a single char,
 246 an octal escape sequence, a special escape like C<\n> or a hex value.
 247
 248 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and
 249 not a '\\'. This is because regexes very often contain backslashed
 250 sequences, whereas '%' is not a particularly common character in patterns.
 251
 252 Returns a pointer to the escaped text as held by dsv.
 253
 254 =cut
 255 */
 256 #define PV_ESCAPE_OCTBUFSIZE 32
 257
 258 char *
 259 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
 260                 const STRLEN count, const STRLEN max,
 261                 STRLEN * const escaped, const U32 flags )
 262 {
 263     const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
 264     const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
 265     char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
 266     STRLEN wrote = 0;    /* chars written so far */
 267     STRLEN chsize = 0;   /* size of data to be written */
 268     STRLEN readsize = 1; /* size of data just read */
 269     bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */
 270     const char *pv  = str;
 271     const char * const end = pv + count; /* end of string */
 272     octbuf[0] = esc;
 273
 274     PERL_ARGS_ASSERT_PV_ESCAPE;
 275
 276     if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) {
 277             /* This won't alter the UTF-8 flag */
 278             sv_setpvs(dsv, "");
 279     }
 280
 281     if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
 282         isuni = 1;
 283
 284     for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
 285         const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
 286         const U8 c = (U8)u & 0xFF;
 287
 288         if ( ( u > 255 )
 289           || (flags & PERL_PV_ESCAPE_ALL)
 290           || (( u > 127 ) && (flags & PERL_PV_ESCAPE_NONASCII)))
 291         {
 292             if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
 293                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 294                                       "%"UVxf, u);
 295             else
 296                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 297                                       "%cx{%"UVxf"}", esc, u);
 298         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
 299             chsize = 1;
 300         } else {
 301             if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
 302                 chsize = 2;
 303                 switch (c) {
 304
 305                 case '\\' : /* fallthrough */
 306                 case '%'  : if ( c == esc )  {
 307                                 octbuf[1] = esc;
 308                             } else {
 309                                 chsize = 1;
 310                             }
 311                             break;
 312                 case '\v' : octbuf[1] = 'v';  break;
 313                 case '\t' : octbuf[1] = 't';  break;
 314                 case '\r' : octbuf[1] = 'r';  break;
 315                 case '\n' : octbuf[1] = 'n';  break;
 316                 case '\f' : octbuf[1] = 'f';  break;
 317                 case '"'  :
 318                         if ( dq == '"' )
 319                                 octbuf[1] = '"';
 320                         else
 321                             chsize = 1;
 322                         break;
 323                 default:
 324                         if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
 325                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 326                                                   "%c%03o", esc, c);
 327                         else
 328                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 329                                                   "%c%o", esc, c);
 330                 }
 331             } else {
 332                 chsize = 1;
 333             }
 334         }
 335         if ( max && (wrote + chsize > max) ) {
 336             break;
 337         } else if (chsize > 1) {
 338             sv_catpvn(dsv, octbuf, chsize);
 339             wrote += chsize;
 340         } else {
 341             /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range
 342                128-255 can be appended raw to the dsv. If dsv happens to be
 343                UTF-8 then we need catpvf to upgrade them for us.
 344                Or add a new API call sv_catpvc(). Think about that name, and
 345                how to keep it clear that it's unlike the s of catpvs, which is
 346                really an array octets, not a string.  */
 347             Perl_sv_catpvf( aTHX_ dsv, "%c", c);
 348             wrote++;
 349         }
 350         if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
 351             break;
 352     }
 353     if (escaped != NULL)
 354         *escaped= pv - str;
 355     return SvPVX(dsv);
 356 }
 357 /*
 358 =for apidoc pv_pretty
 359
 360 Converts a string into something presentable, handling escaping via
 361 pv_escape() and supporting quoting and ellipses.
 362
 363 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
 364 double quoted with any double quotes in the string escaped. Otherwise
 365 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
 366 angle brackets.
 367
 368 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in
 369 string were output then an ellipsis C<...> will be appended to the
 370 string. Note that this happens AFTER it has been quoted.
 371
 372 If start_color is non-null then it will be inserted after the opening
 373 quote (if there is one) but before the escaped text. If end_color
 374 is non-null then it will be inserted after the escaped text but before
 375 any quotes or ellipses.
 376
 377 Returns a pointer to the prettified text as held by dsv.
 378
 379 =cut
 380 */
 381
 382 char *
 383 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
 384   const STRLEN max, char const * const start_color, char const * const end_color,
 385   const U32 flags )
 386 {
 387     const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
 388     STRLEN escaped;
 389
 390     PERL_ARGS_ASSERT_PV_PRETTY;
 391
 392     if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
 393             /* This won't alter the UTF-8 flag */
 394             sv_setpvs(dsv, "");
 395     }
 396
 397     if ( dq == '"' )
 398         sv_catpvs(dsv, "\"");
 399     else if ( flags & PERL_PV_PRETTY_LTGT )
 400         sv_catpvs(dsv, "<");
 401
 402     if ( start_color != NULL )
 403         sv_catpv(dsv, start_color);
 404
 405     pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
 406
 407     if ( end_color != NULL )
 408         sv_catpv(dsv, end_color);
 409
 410     if ( dq == '"' )
 411         sv_catpvs( dsv, "\"");
 412     else if ( flags & PERL_PV_PRETTY_LTGT )
 413         sv_catpvs(dsv, ">");
 414
 415     if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
 416             sv_catpvs(dsv, "...");
 417
 418     return SvPVX(dsv);
 419 }
 420
 421 /*
 422 =for apidoc pv_display
 423
 424 Similar to
 425
 426   pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
 427
 428 except that an additional "\0" will be appended to the string when
 429 len > cur and pv[cur] is "\0".
 430
 431 Note that the final string may be up to 7 chars longer than pvlim.
 432
 433 =cut
 434 */
 435
 436 char *
 437 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
 438 {
 439     PERL_ARGS_ASSERT_PV_DISPLAY;
 440
 441     pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
 442     if (len > cur && pv[cur] == '\0')
 443             sv_catpvs( dsv, "\\0");
 444     return SvPVX(dsv);
 445 }
 446
 447 char *
 448 Perl_sv_peek(pTHX_ SV *sv)
 449 {
 450     dVAR;
 451     SV * const t = sv_newmortal();
 452     int unref = 0;
 453     U32 type;
 454
 455     sv_setpvs(t, "");
 456   retry:
 457     if (!sv) {
 458         sv_catpv(t, "VOID");
 459         goto finish;
 460     }
 461     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
 462         sv_catpv(t, "WILD");
 463         goto finish;
 464     }
 465     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
 466         if (sv == &PL_sv_undef) {
 467             sv_catpv(t, "SV_UNDEF");
 468             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 469                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 470                 SvREADONLY(sv))
 471                 goto finish;
 472         }
 473         else if (sv == &PL_sv_no) {
 474             sv_catpv(t, "SV_NO");
 475             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 476                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 477                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 478                                   SVp_POK|SVp_NOK)) &&
 479                 SvCUR(sv) == 0 &&
 480                 SvNVX(sv) == 0.0)
 481                 goto finish;
 482         }
 483         else if (sv == &PL_sv_yes) {
 484             sv_catpv(t, "SV_YES");
 485             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 486                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 487                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 488                                   SVp_POK|SVp_NOK)) &&
 489                 SvCUR(sv) == 1 &&
 490                 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
 491                 SvNVX(sv) == 1.0)
 492                 goto finish;
 493         }
 494         else {
 495             sv_catpv(t, "SV_PLACEHOLDER");
 496             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 497                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 498                 SvREADONLY(sv))
 499                 goto finish;
 500         }
 501         sv_catpv(t, ":");
 502     }
 503     else if (SvREFCNT(sv) == 0) {
 504         sv_catpv(t, "(");
 505         unref++;
 506     }
 507     else if (DEBUG_R_TEST_) {
 508         int is_tmp = 0;
 509         I32 ix;
 510         /* is this SV on the tmps stack? */
 511         for (ix=PL_tmps_ix; ix>=0; ix--) {
 512             if (PL_tmps_stack[ix] == sv) {
 513                 is_tmp = 1;
 514                 break;
 515             }
 516         }
 517         if (SvREFCNT(sv) > 1)
 518             Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
 519                     is_tmp ? "T" : "");
 520         else if (is_tmp)
 521             sv_catpv(t, "<T>");
 522     }
 523
 524     if (SvROK(sv)) {
 525         sv_catpv(t, "\\");
 526         if (SvCUR(t) + unref > 10) {
 527             SvCUR_set(t, unref + 3);
 528             *SvEND(t) = '\0';
 529             sv_catpv(t, "...");
 530             goto finish;
 531         }
 532         sv = SvRV(sv);
 533         goto retry;
 534     }
 535     type = SvTYPE(sv);
 536     if (type == SVt_PVCV) {
 537         Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
 538         goto finish;
 539     } else if (type < SVt_LAST) {
 540         sv_catpv(t, svshorttypenames[type]);
 541
 542         if (type == SVt_NULL)
 543             goto finish;
 544     } else {
 545         sv_catpv(t, "FREED");
 546         goto finish;
 547     }
 548
 549     if (SvPOKp(sv)) {
 550         if (!SvPVX_const(sv))
 551             sv_catpv(t, "(null)");
 552         else {
 553             SV * const tmp = newSVpvs("");
 554             sv_catpv(t, "(");
 555             if (SvOOK(sv)) {
 556                 STRLEN delta;
 557                 SvOOK_offset(sv, delta);
 558                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
 559             }
 560             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
 561             if (SvUTF8(sv))
 562                 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
 563                                sv_uni_display(tmp, sv, 6 * SvCUR(sv),
 564                                               UNI_DISPLAY_QQ));
 565             SvREFCNT_dec(tmp);
 566         }
 567     }
 568     else if (SvNOKp(sv)) {
 569         STORE_NUMERIC_LOCAL_SET_STANDARD();
 570         Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
 571         RESTORE_NUMERIC_LOCAL();
 572     }
 573     else if (SvIOKp(sv)) {
 574         if (SvIsUV(sv))
 575             Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
 576         else
 577             Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
 578     }
 579     else
 580         sv_catpv(t, "()");
 581
 582   finish:
 583     while (unref--)
 584         sv_catpv(t, ")");
 585     if (PL_tainting && SvTAINTED(sv))
 586         sv_catpv(t, " [tainted]");
 587     return SvPV_nolen(t);
 588 }
 589
 590 void
 591 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
 592 {
 593     char ch;
 594
 595     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
 596
 597     if (!pm) {
 598         Perl_dump_indent(aTHX_ level, file, "{}\n");
 599         return;
 600     }
 601     Perl_dump_indent(aTHX_ level, file, "{\n");
 602     level++;
 603     if (pm->op_pmflags & PMf_ONCE)
 604         ch = '?';
 605     else
 606         ch = '/';
 607     if (PM_GETRE(pm))
 608         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
 609              ch, RX_PRECOMP(PM_GETRE(pm)), ch,
 610              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
 611     else
 612         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
 613     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
 614         Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
 615         op_dump(pm->op_pmreplrootu.op_pmreplroot);
 616     }
 617     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
 618         SV * const tmpsv = pm_description(pm);
 619         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 620         SvREFCNT_dec(tmpsv);
 621     }
 622
 623     Perl_dump_indent(aTHX_ level-1, file, "}\n");
 624 }
 625
 626 const struct flag_to_name pmflags_flags_names[] = {
 627     {PMf_CONST, ",CONST"},
 628     {PMf_KEEP, ",KEEP"},
 629     {PMf_GLOBAL, ",GLOBAL"},
 630     {PMf_CONTINUE, ",CONTINUE"},
 631     {PMf_RETAINT, ",RETAINT"},
 632     {PMf_EVAL, ",EVAL"},
 633     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
 634 };
 635
 636 static SV *
 637 S_pm_description(pTHX_ const PMOP *pm)
 638 {
 639     SV * const desc = newSVpvs("");
 640     const REGEXP * const regex = PM_GETRE(pm);
 641     const U32 pmflags = pm->op_pmflags;
 642
 643     PERL_ARGS_ASSERT_PM_DESCRIPTION;
 644
 645     if (pmflags & PMf_ONCE)
 646         sv_catpv(desc, ",ONCE");
 647 #ifdef USE_ITHREADS
 648     if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
 649         sv_catpv(desc, ":USED");
 650 #else
 651     if (pmflags & PMf_USED)
 652         sv_catpv(desc, ":USED");
 653 #endif
 654
 655     if (regex) {
 656         if (RX_EXTFLAGS(regex) & RXf_TAINTED)
 657             sv_catpv(desc, ",TAINTED");
 658         if (RX_CHECK_SUBSTR(regex)) {
 659             if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN))
 660                 sv_catpv(desc, ",SCANFIRST");
 661             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
 662                 sv_catpv(desc, ",ALL");
 663         }
 664         if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
 665             sv_catpv(desc, ",SKIPWHITE");
 666     }
 667
 668     append_flags(desc, pmflags, pmflags_flags_names);
 669     return desc;
 670 }
 671
 672 void
 673 Perl_pmop_dump(pTHX_ PMOP *pm)
 674 {
 675     do_pmop_dump(0, Perl_debug_log, pm);
 676 }
 677
 678 /* An op sequencer.  We visit the ops in the order they're to execute. */
 679
 680 STATIC void
 681 S_sequence(pTHX_ register const OP *o)
 682 {
 683     dVAR;
 684     const OP *oldop = NULL;
 685
 686     if (!o)
 687         return;
 688
 689 #ifdef PERL_MAD
 690     if (o->op_next == 0)
 691         return;
 692 #endif
 693
 694     if (!Sequence)
 695         Sequence = newHV();
 696
 697     for (; o; o = o->op_next) {
 698         STRLEN len;
 699         SV * const op = newSVuv(PTR2UV(o));
 700         const char * const key = SvPV_const(op, len);
 701
 702         if (hv_exists(Sequence, key, len))
 703             break;
 704
 705         switch (o->op_type) {
 706         case OP_STUB:
 707             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
 708                 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 709                 break;
 710             }
 711             goto nothin;
 712         case OP_NULL:
 713 #ifdef PERL_MAD
 714             if (o == o->op_next)
 715                 return;
 716 #endif
 717             if (oldop && o->op_next)
 718                 continue;
 719             break;
 720         case OP_SCALAR:
 721         case OP_LINESEQ:
 722         case OP_SCOPE:
 723           nothin:
 724             if (oldop && o->op_next)
 725                 continue;
 726             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 727             break;
 728
 729         case OP_MAPWHILE:
 730         case OP_GREPWHILE:
 731         case OP_AND:
 732         case OP_OR:
 733         case OP_DOR:
 734         case OP_ANDASSIGN:
 735         case OP_ORASSIGN:
 736         case OP_DORASSIGN:
 737         case OP_COND_EXPR:
 738         case OP_RANGE:
 739             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 740             sequence_tail(cLOGOPo->op_other);
 741             break;
 742
 743         case OP_ENTERLOOP:
 744         case OP_ENTERITER:
 745             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 746             sequence_tail(cLOOPo->op_redoop);
 747             sequence_tail(cLOOPo->op_nextop);
 748             sequence_tail(cLOOPo->op_lastop);
 749             break;
 750
 751         case OP_SUBST:
 752             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 753             sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart);
 754             break;
 755
 756         case OP_QR:
 757         case OP_MATCH:
 758         case OP_HELEM:
 759             break;
 760
 761         default:
 762             (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0);
 763             break;
 764         }
 765         oldop = o;
 766     }
 767 }
 768
 769 static void
 770 S_sequence_tail(pTHX_ const OP *o)
 771 {
 772     while (o && (o->op_type == OP_NULL))
 773         o = o->op_next;
 774     sequence(o);
 775 }
 776
 777 STATIC UV
 778 S_sequence_num(pTHX_ const OP *o)
 779 {
 780     dVAR;
 781     SV     *op,
 782           **seq;
 783     const char *key;
 784     STRLEN  len;
 785     if (!o) return 0;
 786     op = newSVuv(PTR2UV(o));
 787     key = SvPV_const(op, len);
 788     seq = hv_fetch(Sequence, key, len, 0);
 789     return seq ? SvUV(*seq): 0;
 790 }
 791
 792 const struct flag_to_name op_flags_names[] = {
 793     {OPf_KIDS, ",KIDS"},
 794     {OPf_PARENS, ",PARENS"},
 795     {OPf_REF, ",REF"},
 796     {OPf_MOD, ",MOD"},
 797     {OPf_STACKED, ",STACKED"},
 798     {OPf_SPECIAL, ",SPECIAL"}
 799 };
 800
 801 const struct flag_to_name op_trans_names[] = {
 802     {OPpTRANS_FROM_UTF, ",FROM_UTF"},
 803     {OPpTRANS_TO_UTF, ",TO_UTF"},
 804     {OPpTRANS_IDENTICAL, ",IDENTICAL"},
 805     {OPpTRANS_SQUASH, ",SQUASH"},
 806     {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
 807     {OPpTRANS_GROWS, ",GROWS"},
 808     {OPpTRANS_DELETE, ",DELETE"}
 809 };
 810
 811 const struct flag_to_name op_entersub_names[] = {
 812     {OPpENTERSUB_DB, ",DB"},
 813     {OPpENTERSUB_HASTARG, ",HASTARG"},
 814     {OPpENTERSUB_NOMOD, ",NOMOD"},
 815     {OPpENTERSUB_AMPER, ",AMPER"},
 816     {OPpENTERSUB_NOPAREN, ",NOPAREN"},
 817     {OPpENTERSUB_INARGS, ",INARGS"}
 818 };
 819
 820 const struct flag_to_name op_const_names[] = {
 821     {OPpCONST_NOVER, ",NOVER"},
 822     {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
 823     {OPpCONST_STRICT, ",STRICT"},
 824     {OPpCONST_ENTERED, ",ENTERED"},
 825     {OPpCONST_ARYBASE, ",ARYBASE"},
 826     {OPpCONST_BARE, ",BARE"},
 827     {OPpCONST_WARNING, ",WARNING"}
 828 };
 829
 830 const struct flag_to_name op_sort_names[] = {
 831     {OPpSORT_NUMERIC, ",NUMERIC"},
 832     {OPpSORT_INTEGER, ",INTEGER"},
 833     {OPpSORT_REVERSE, ",REVERSE"},
 834     {OPpSORT_INPLACE, ",INPLACE"},
 835     {OPpSORT_DESCEND, ",DESCEND"},
 836     {OPpSORT_QSORT, ",QSORT"},
 837     {OPpSORT_STABLE, ",STABLE"}
 838 };
 839
 840 const struct flag_to_name op_open_names[] = {
 841     {OPpOPEN_IN_RAW, ",IN_RAW"},
 842     {OPpOPEN_IN_CRLF, ",IN_CRLF"},
 843     {OPpOPEN_OUT_RAW, ",OUT_RAW"},
 844     {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
 845 };
 846
 847 const struct flag_to_name op_exit_names[] = {
 848     {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
 849     {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
 850 };
 851
 852 #define OP_PRIVATE_ONCE(op, flag, name) \
 853     const struct flag_to_name CAT2(op, _names)[] = {    \
 854         {(flag), (name)} \
 855     }
 856
 857 OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
 858 OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
 859 OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
 860 OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
 861 OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
 862 OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
 863 OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
 864 OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
 865 OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
 866 OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
 867 OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
 868 OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
 869
 870 struct op_private_by_op {
 871     U16 op_type;
 872     U16 len;
 873     const struct flag_to_name *start;
 874 };
 875
 876 const struct op_private_by_op op_private_names[] = {
 877     {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 878     {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 879     {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 880     {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
 881     {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
 882     {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
 883     {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
 884     {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
 885     {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
 886     {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
 887     {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
 888     {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
 889     {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
 890     {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
 891     {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
 892     {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
 893     {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
 894     {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
 895     {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
 896     {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
 897     {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
 898 };
 899
 900 static bool
 901 S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
 902     const struct op_private_by_op *start = op_private_names;
 903     const struct op_private_by_op *const end
 904         = op_private_names + C_ARRAY_LENGTH(op_private_names);
 905
 906     /* This is a linear search, but no worse than the code that it replaced.
 907        It's debugging code - size is more important than speed.  */
 908     do {
 909         if (optype == start->op_type) {
 910             S_append_flags(aTHX_ tmpsv, op_private, start->start,
 911                            start->start + start->len);
 912             return TRUE;
 913         }
 914     } while (++start < end);
 915     return FALSE;
 916 }
 917
 918 void
 919 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 920 {
 921     dVAR;
 922     UV      seq;
 923     const OPCODE optype = o->op_type;
 924
 925     PERL_ARGS_ASSERT_DO_OP_DUMP;
 926
 927     sequence(o);
 928     Perl_dump_indent(aTHX_ level, file, "{\n");
 929     level++;
 930     seq = sequence_num(o);
 931     if (seq)
 932         PerlIO_printf(file, "%-4"UVuf, seq);
 933     else
 934         PerlIO_printf(file, "    ");
 935     PerlIO_printf(file,
 936                   "%*sTYPE = %s  ===> ",
 937                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
 938     if (o->op_next)
 939         PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n",
 940                                 sequence_num(o->op_next));
 941     else
 942         PerlIO_printf(file, "DONE\n");
 943     if (o->op_targ) {
 944         if (optype == OP_NULL) {
 945             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
 946             if (o->op_targ == OP_NEXTSTATE) {
 947                 if (CopLINE(cCOPo))
 948                     Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
 949                                      (UV)CopLINE(cCOPo));
 950                 if (CopSTASHPV(cCOPo))
 951                     Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
 952                                      CopSTASHPV(cCOPo));
 953                 if (CopLABEL(cCOPo))
 954                     Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
 955                                      CopLABEL(cCOPo));
 956             }
 957         }
 958         else
 959             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
 960     }
 961 #ifdef DUMPADDR
 962     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
 963 #endif
 964     if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
 965         SV * const tmpsv = newSVpvs("");
 966         switch (o->op_flags & OPf_WANT) {
 967         case OPf_WANT_VOID:
 968             sv_catpv(tmpsv, ",VOID");
 969             break;
 970         case OPf_WANT_SCALAR:
 971             sv_catpv(tmpsv, ",SCALAR");
 972             break;
 973         case OPf_WANT_LIST:
 974             sv_catpv(tmpsv, ",LIST");
 975             break;
 976         default:
 977             sv_catpv(tmpsv, ",UNKNOWN");
 978             break;
 979         }
 980         append_flags(tmpsv, o->op_flags, op_flags_names);
 981         if (o->op_latefree)
 982             sv_catpv(tmpsv, ",LATEFREE");
 983         if (o->op_latefreed)
 984             sv_catpv(tmpsv, ",LATEFREED");
 985         if (o->op_attached)
 986             sv_catpv(tmpsv, ",ATTACHED");
 987         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 988         SvREFCNT_dec(tmpsv);
 989     }
 990     if (o->op_private) {
 991         SV * const tmpsv = newSVpvs("");
 992         if (PL_opargs[optype] & OA_TARGLEX) {
 993             if (o->op_private & OPpTARGET_MY)
 994                 sv_catpv(tmpsv, ",TARGET_MY");
 995         }
 996         else if (optype == OP_ENTERSUB ||
 997             optype == OP_RV2SV ||
 998             optype == OP_GVSV ||
 999             optype == OP_RV2AV ||
1000             optype == OP_RV2HV ||
1001             optype == OP_RV2GV ||
1002             optype == OP_AELEM ||
1003             optype == OP_HELEM )
1004         {
1005             if (optype == OP_ENTERSUB) {
1006                 append_flags(tmpsv, o->op_private, op_entersub_names);
1007             }
1008             else {
1009                 switch (o->op_private & OPpDEREF) {
1010                 case OPpDEREF_SV:
1011                     sv_catpv(tmpsv, ",SV");
1012                     break;
1013                 case OPpDEREF_AV:
1014                     sv_catpv(tmpsv, ",AV");
1015                     break;
1016                 case OPpDEREF_HV:
1017                     sv_catpv(tmpsv, ",HV");
1018                     break;
1019                 }
1020                 if (o->op_private & OPpMAYBE_LVSUB)
1021                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
1022             }
1023
1024             if ((optype==OP_RV2SV || optype==OP_RV2AV || optype==OP_RV2HV)
1025                     && (o->op_private & OPpDEREFed))
1026                 sv_catpv(tmpsv, ",DEREFed");
1027
1028             if (optype == OP_AELEM || optype == OP_HELEM) {
1029                 if (o->op_private & OPpLVAL_DEFER)
1030                     sv_catpv(tmpsv, ",LVAL_DEFER");
1031             }
1032             else {
1033                 if (o->op_private & HINT_STRICT_REFS)
1034                     sv_catpv(tmpsv, ",STRICT_REFS");
1035                 if (o->op_private & OPpOUR_INTRO)
1036                     sv_catpv(tmpsv, ",OUR_INTRO");
1037             }
1038         }
1039         else if (S_op_private_to_names(aTHX_ tmpsv, optype, o->op_private)) {
1040         }
1041         else if (PL_check[optype] != Perl_ck_ftst) {
1042             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
1043                 sv_catpv(tmpsv, ",FT_ACCESS");
1044             if (o->op_private & OPpFT_STACKED)
1045                 sv_catpv(tmpsv, ",FT_STACKED");
1046         }
1047         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
1048             sv_catpv(tmpsv, ",INTRO");
1049         if (SvCUR(tmpsv))
1050             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
1051         SvREFCNT_dec(tmpsv);
1052     }
1053
1054 #ifdef PERL_MAD
1055     if (PL_madskills && o->op_madprop) {
1056         SV * const tmpsv = newSVpvs("");
1057         MADPROP* mp = o->op_madprop;
1058         Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n");
1059         level++;
1060         while (mp) {
1061             const char tmp = mp->mad_key;
1062             sv_setpvs(tmpsv,"'");
1063             if (tmp)
1064                 sv_catpvn(tmpsv, &tmp, 1);
1065             sv_catpv(tmpsv, "'=");
1066             switch (mp->mad_type) {
1067             case MAD_NULL:
1068                 sv_catpv(tmpsv, "NULL");
1069                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1070                 break;
1071             case MAD_PV:
1072                 sv_catpv(tmpsv, "<");
1073                 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen);
1074                 sv_catpv(tmpsv, ">");
1075                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1076                 break;
1077             case MAD_OP:
1078                 if ((OP*)mp->mad_val) {
1079                     Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1080                     do_op_dump(level, file, (OP*)mp->mad_val);
1081                 }
1082                 break;
1083             default:
1084                 sv_catpv(tmpsv, "(UNK)");
1085                 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv));
1086                 break;
1087             }
1088             mp = mp->mad_next;
1089         }
1090         level--;
1091         Perl_dump_indent(aTHX_ level, file, "}\n");
1092
1093         SvREFCNT_dec(tmpsv);
1094     }
1095 #endif
1096
1097     switch (optype) {
1098     case OP_AELEMFAST:
1099     case OP_GVSV:
1100     case OP_GV:
1101 #ifdef USE_ITHREADS
1102         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
1103 #else
1104         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
1105             if (cSVOPo->op_sv) {
1106                 SV * const tmpsv = newSV(0);
1107                 ENTER;
1108                 SAVEFREESV(tmpsv);
1109 #ifdef PERL_MAD
1110                 /* FIXME - is this making unwarranted assumptions about the
1111                    UTF-8 cleanliness of the dump file handle?  */
1112                 SvUTF8_on(tmpsv);
1113 #endif
1114                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
1115                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
1116                                  SvPV_nolen_const(tmpsv));
1117                 LEAVE;
1118             }
1119             else
1120                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
1121         }
1122 #endif
1123         break;
1124     case OP_CONST:
1125     case OP_HINTSEVAL:
1126     case OP_METHOD_NAMED:
1127 #ifndef USE_ITHREADS
1128         /* with ITHREADS, consts are stored in the pad, and the right pad
1129          * may not be active here, so skip */
1130         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
1131 #endif
1132         break;
1133     case OP_NEXTSTATE:
1134     case OP_DBSTATE:
1135         if (CopLINE(cCOPo))
1136             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
1137                              (UV)CopLINE(cCOPo));
1138         if (CopSTASHPV(cCOPo))
1139             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1140                              CopSTASHPV(cCOPo));
1141         if (CopLABEL(cCOPo))
1142             Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1143                              CopLABEL(cCOPo));
1144         break;
1145     case OP_ENTERLOOP:
1146         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1147         if (cLOOPo->op_redoop)
1148             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1149         else
1150             PerlIO_printf(file, "DONE\n");
1151         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1152         if (cLOOPo->op_nextop)
1153             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1154         else
1155             PerlIO_printf(file, "DONE\n");
1156         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1157         if (cLOOPo->op_lastop)
1158             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1159         else
1160             PerlIO_printf(file, "DONE\n");
1161         break;
1162     case OP_COND_EXPR:
1163     case OP_RANGE:
1164     case OP_MAPWHILE:
1165     case OP_GREPWHILE:
1166     case OP_OR:
1167     case OP_AND:
1168         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1169         if (cLOGOPo->op_other)
1170             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1171         else
1172             PerlIO_printf(file, "DONE\n");
1173         break;
1174     case OP_PUSHRE:
1175     case OP_MATCH:
1176     case OP_QR:
1177     case OP_SUBST:
1178         do_pmop_dump(level, file, cPMOPo);
1179         break;
1180     case OP_LEAVE:
1181     case OP_LEAVEEVAL:
1182     case OP_LEAVESUB:
1183     case OP_LEAVESUBLV:
1184     case OP_LEAVEWRITE:
1185     case OP_SCOPE:
1186         if (o->op_private & OPpREFCOUNTED)
1187             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1188         break;
1189     default:
1190         break;
1191     }
1192     if (o->op_flags & OPf_KIDS) {
1193         OP *kid;
1194         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1195             do_op_dump(level, file, kid);
1196     }
1197     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1198 }
1199
1200 void
1201 Perl_op_dump(pTHX_ const OP *o)
1202 {
1203     PERL_ARGS_ASSERT_OP_DUMP;
1204     do_op_dump(0, Perl_debug_log, o);
1205 }
1206
1207 void
1208 Perl_gv_dump(pTHX_ GV *gv)
1209 {
1210     SV *sv;
1211
1212     PERL_ARGS_ASSERT_GV_DUMP;
1213
1214     if (!gv) {
1215         PerlIO_printf(Perl_debug_log, "{}\n");
1216         return;
1217     }
1218     sv = sv_newmortal();
1219     PerlIO_printf(Perl_debug_log, "{\n");
1220     gv_fullname3(sv, gv, NULL);
1221     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
1222     if (gv != GvEGV(gv)) {
1223         gv_efullname3(sv, GvEGV(gv), NULL);
1224         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
1225     }
1226     PerlIO_putc(Perl_debug_log, '\n');
1227     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1228 }
1229
1230
1231 /* map magic types to the symbolic names
1232  * (with the PERL_MAGIC_ prefixed stripped)
1233  */
1234
1235 static const struct { const char type; const char *name; } magic_names[] = {
1236 #include "mg_names.c"
1237         /* this null string terminates the list */
1238         { 0,                         NULL },
1239 };
1240
1241 void
1242 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1243 {
1244     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1245
1246     for (; mg; mg = mg->mg_moremagic) {
1247         Perl_dump_indent(aTHX_ level, file,
1248                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1249         if (mg->mg_virtual) {
1250             const MGVTBL * const v = mg->mg_virtual;
1251             if (v >= PL_magic_vtables
1252                 && v < PL_magic_vtables + magic_vtable_max) {
1253                 const U32 i = v - PL_magic_vtables;
1254                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1255             }
1256             else
1257                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1258         }
1259         else
1260             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1261
1262         if (mg->mg_private)
1263             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1264
1265         {
1266             int n;
1267             const char *name = NULL;
1268             for (n = 0; magic_names[n].name; n++) {
1269                 if (mg->mg_type == magic_names[n].type) {
1270                     name = magic_names[n].name;
1271                     break;
1272                 }
1273             }
1274             if (name)
1275                 Perl_dump_indent(aTHX_ level, file,
1276                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1277             else
1278                 Perl_dump_indent(aTHX_ level, file,
1279                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1280         }
1281
1282         if (mg->mg_flags) {
1283             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1284             if (mg->mg_type == PERL_MAGIC_envelem &&
1285                 mg->mg_flags & MGf_TAINTEDDIR)
1286                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1287             if (mg->mg_type == PERL_MAGIC_regex_global &&
1288                 mg->mg_flags & MGf_MINMATCH)
1289                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1290             if (mg->mg_flags & MGf_REFCOUNTED)
1291                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1292             if (mg->mg_flags & MGf_GSKIP)
1293                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1294             if (mg->mg_flags & MGf_COPY)
1295                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1296             if (mg->mg_flags & MGf_DUP)
1297                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1298             if (mg->mg_flags & MGf_LOCAL)
1299                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1300         }
1301         if (mg->mg_obj) {
1302             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1303                 PTR2UV(mg->mg_obj));
1304             if (mg->mg_type == PERL_MAGIC_qr) {
1305                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1306                 SV * const dsv = sv_newmortal();
1307                 const char * const s
1308                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1309                     60, NULL, NULL,
1310                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1311                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1312                 );
1313                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1314                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1315                         (IV)RX_REFCNT(re));
1316             }
1317             if (mg->mg_flags & MGf_REFCOUNTED)
1318                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1319         }
1320         if (mg->mg_len)
1321             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1322         if (mg->mg_ptr) {
1323             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1324             if (mg->mg_len >= 0) {
1325                 if (mg->mg_type != PERL_MAGIC_utf8) {
1326                     SV * const sv = newSVpvs("");
1327                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1328                     SvREFCNT_dec(sv);
1329                 }
1330             }
1331             else if (mg->mg_len == HEf_SVKEY) {
1332                 PerlIO_puts(file, " => HEf_SVKEY\n");
1333                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1334                            maxnest, dumpops, pvlim); /* MG is already +1 */
1335                 continue;
1336             }
1337             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1338             else
1339                 PerlIO_puts(
1340                   file,
1341                  " ???? - " __FILE__
1342                  " does not know how to handle this MG_LEN"
1343                 );
1344             PerlIO_putc(file, '\n');
1345         }
1346         if (mg->mg_type == PERL_MAGIC_utf8) {
1347             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1348             if (cache) {
1349                 IV i;
1350                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1351                     Perl_dump_indent(aTHX_ level, file,
1352                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1353                                      i,
1354                                      (UV)cache[i * 2],
1355                                      (UV)cache[i * 2 + 1]);
1356             }
1357         }
1358     }
1359 }
1360
1361 void
1362 Perl_magic_dump(pTHX_ const MAGIC *mg)
1363 {
1364     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1365 }
1366
1367 void
1368 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1369 {
1370     const char *hvname;
1371
1372     PERL_ARGS_ASSERT_DO_HV_DUMP;
1373
1374     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1375     if (sv && (hvname = HvNAME_get(sv)))
1376     {
1377         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1378            name which quite legally could contain insane things like tabs, newlines, nulls or
1379            other scary crap - this should produce sane results - except maybe for unicode package
1380            names - but we will wait for someone to file a bug on that - demerphq */
1381         SV * const tmpsv = newSVpvs("");
1382         PerlIO_printf(file, "\t%s\n", pv_display(tmpsv, hvname, HvNAMELEN_get(sv), 0, 1024));
1383     }
1384     else
1385         PerlIO_putc(file, '\n');
1386 }
1387
1388 void
1389 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1390 {
1391     PERL_ARGS_ASSERT_DO_GV_DUMP;
1392
1393     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1394     if (sv && GvNAME(sv))
1395         PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1396     else
1397         PerlIO_putc(file, '\n');
1398 }
1399
1400 void
1401 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1402 {
1403     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1404
1405     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1406     if (sv && GvNAME(sv)) {
1407         const char *hvname;
1408         PerlIO_printf(file, "\t\"");
1409         if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1410             PerlIO_printf(file, "%s\" :: \"", hvname);
1411         PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1412     }
1413     else
1414         PerlIO_putc(file, '\n');
1415 }
1416
1417 const struct flag_to_name first_sv_flags_names[] = {
1418     {SVs_TEMP, "TEMP,"},
1419     {SVs_OBJECT, "OBJECT,"},
1420     {SVs_GMG, "GMG,"},
1421     {SVs_SMG, "SMG,"},
1422     {SVs_RMG, "RMG,"},
1423     {SVf_IOK, "IOK,"},
1424     {SVf_NOK, "NOK,"},
1425     {SVf_POK, "POK,"}
1426 };
1427
1428 const struct flag_to_name second_sv_flags_names[] = {
1429     {SVf_OOK, "OOK,"},
1430     {SVf_FAKE, "FAKE,"},
1431     {SVf_READONLY, "READONLY,"},
1432     {SVf_BREAK, "BREAK,"},
1433     {SVf_AMAGIC, "OVERLOAD,"},
1434     {SVp_IOK, "pIOK,"},
1435     {SVp_NOK, "pNOK,"},
1436     {SVp_POK, "pPOK,"}
1437 };
1438
1439 const struct flag_to_name cv_flags_names[] = {
1440     {CVf_ANON, "ANON,"},
1441     {CVf_UNIQUE, "UNIQUE,"},
1442     {CVf_CLONE, "CLONE,"},
1443     {CVf_CLONED, "CLONED,"},
1444     {CVf_CONST, "CONST,"},
1445     {CVf_NODEBUG, "NODEBUG,"},
1446     {CVf_LVALUE, "LVALUE,"},
1447     {CVf_METHOD, "METHOD,"},
1448     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1449     {CVf_CVGV_RC, "CVGV_RC,"},
1450     {CVf_ISXSUB, "ISXSUB,"}
1451 };
1452
1453 const struct flag_to_name hv_flags_names[] = {
1454     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1455     {SVphv_LAZYDEL, "LAZYDEL,"},
1456     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1457     {SVphv_REHASH, "REHASH,"},
1458     {SVphv_CLONEABLE, "CLONEABLE,"}
1459 };
1460
1461 const struct flag_to_name gp_flags_names[] = {
1462     {GVf_INTRO, "INTRO,"},
1463     {GVf_MULTI, "MULTI,"},
1464     {GVf_ASSUMECV, "ASSUMECV,"},
1465     {GVf_IN_PAD, "IN_PAD,"}
1466 };
1467
1468 const struct flag_to_name gp_flags_imported_names[] = {
1469     {GVf_IMPORTED_SV, " SV"},
1470     {GVf_IMPORTED_AV, " AV"},
1471     {GVf_IMPORTED_HV, " HV"},
1472     {GVf_IMPORTED_CV, " CV"},
1473 };
1474
1475 const struct flag_to_name regexp_flags_names[] = {
1476     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1477     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1478     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1479     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1480     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1481     {RXf_ANCH_BOL,        "ANCH_BOL,"},
1482     {RXf_ANCH_MBOL,       "ANCH_MBOL,"},
1483     {RXf_ANCH_SBOL,       "ANCH_SBOL,"},
1484     {RXf_ANCH_GPOS,       "ANCH_GPOS,"},
1485     {RXf_GPOS_SEEN,       "GPOS_SEEN,"},
1486     {RXf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1487     {RXf_LOOKBEHIND_SEEN, "LOOKBEHIND_SEEN,"},
1488     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1489     {RXf_CANY_SEEN,       "CANY_SEEN,"},
1490     {RXf_NOSCAN,          "NOSCAN,"},
1491     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1492     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1493     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1494     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1495     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1496     {RXf_SPLIT,           "SPLIT,"},
1497     {RXf_COPY_DONE,       "COPY_DONE,"},
1498     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1499     {RXf_TAINTED,         "TAINTED,"},
1500     {RXf_START_ONLY,      "START_ONLY,"},
1501     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1502     {RXf_WHITE,           "WHITE,"},
1503     {RXf_NULL,            "NULL,"},
1504 };
1505
1506 void
1507 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1508 {
1509     dVAR;
1510     SV *d;
1511     const char *s;
1512     U32 flags;
1513     U32 type;
1514
1515     PERL_ARGS_ASSERT_DO_SV_DUMP;
1516
1517     if (!sv) {
1518         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1519         return;
1520     }
1521
1522     flags = SvFLAGS(sv);
1523     type = SvTYPE(sv);
1524
1525     /* process general SV flags */
1526
1527     d = Perl_newSVpvf(aTHX_
1528                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1529                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1530                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1531                    (int)(PL_dumpindent*level), "");
1532
1533     if (!((flags & SVpad_NAME) == SVpad_NAME
1534           && (type == SVt_PVMG || type == SVt_PVNV))) {
1535         if (flags & SVs_PADSTALE)       sv_catpv(d, "PADSTALE,");
1536     }
1537     if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
1538         if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
1539         if (flags & SVs_PADMY)  sv_catpv(d, "PADMY,");
1540     }
1541     append_flags(d, flags, first_sv_flags_names);
1542     if (flags & SVf_ROK)  {
1543                                 sv_catpv(d, "ROK,");
1544         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1545     }
1546     append_flags(d, flags, second_sv_flags_names);
1547     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1548         if (SvPCS_IMPORTED(sv))
1549                                 sv_catpv(d, "PCS_IMPORTED,");
1550         else
1551                                 sv_catpv(d, "SCREAM,");
1552     }
1553
1554     /* process type-specific SV flags */
1555
1556     switch (type) {
1557     case SVt_PVCV:
1558     case SVt_PVFM:
1559         append_flags(d, CvFLAGS(sv), cv_flags_names);
1560         break;
1561     case SVt_PVHV:
1562         append_flags(d, flags, hv_flags_names);
1563         break;
1564     case SVt_PVGV:
1565     case SVt_PVLV:
1566         if (isGV_with_GP(sv)) {
1567             append_flags(d, GvFLAGS(sv), gp_flags_names);
1568         }
1569         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1570             sv_catpv(d, "IMPORT");
1571             if (GvIMPORTED(sv) == GVf_IMPORTED)
1572                 sv_catpv(d, "ALL,");
1573             else {
1574                 sv_catpv(d, "(");
1575                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1576                 sv_catpv(d, " ),");
1577             }
1578         }
1579         /* FALL THROUGH */
1580     default:
1581     evaled_or_uv:
1582         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1583         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1584         break;
1585     case SVt_PVMG:
1586         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1587         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1588         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1589         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1590         /* FALL THROUGH */
1591     case SVt_PVNV:
1592         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1593         goto evaled_or_uv;
1594     case SVt_PVAV:
1595         break;
1596     }
1597     /* SVphv_SHAREKEYS is also 0x20000000 */
1598     if ((type != SVt_PVHV) && SvUTF8(sv))
1599         sv_catpv(d, "UTF8");
1600
1601     if (*(SvEND(d) - 1) == ',') {
1602         SvCUR_set(d, SvCUR(d) - 1);
1603         SvPVX(d)[SvCUR(d)] = '\0';
1604     }
1605     sv_catpv(d, ")");
1606     s = SvPVX_const(d);
1607
1608     /* dump initial SV details */
1609
1610 #ifdef DEBUG_LEAKING_SCALARS
1611     Perl_dump_indent(aTHX_ level, file,
1612         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1613         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1614         sv->sv_debug_line,
1615         sv->sv_debug_inpad ? "for" : "by",
1616         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1617         PTR2UV(sv->sv_debug_parent),
1618         sv->sv_debug_serial
1619     );
1620 #endif
1621     Perl_dump_indent(aTHX_ level, file, "SV = ");
1622
1623     /* Dump SV type */
1624
1625     if (type < SVt_LAST) {
1626         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1627
1628         if (type ==  SVt_NULL) {
1629             SvREFCNT_dec(d);
1630             return;
1631         }
1632     } else {
1633         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1634         SvREFCNT_dec(d);
1635         return;
1636     }
1637
1638     /* Dump general SV fields */
1639
1640     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1641          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1642          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1643         || (type == SVt_IV && !SvROK(sv))) {
1644         if (SvIsUV(sv)
1645 #ifdef PERL_OLD_COPY_ON_WRITE
1646                        || SvIsCOW(sv)
1647 #endif
1648                                      )
1649             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1650         else
1651             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1652 #ifdef PERL_OLD_COPY_ON_WRITE
1653         if (SvIsCOW_shared_hash(sv))
1654             PerlIO_printf(file, "  (HASH)");
1655         else if (SvIsCOW_normal(sv))
1656             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1657 #endif
1658         PerlIO_putc(file, '\n');
1659     }
1660
1661     if ((type == SVt_PVNV || type == SVt_PVMG)
1662         && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
1663         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1664                          (UV) COP_SEQ_RANGE_LOW(sv));
1665         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1666                          (UV) COP_SEQ_RANGE_HIGH(sv));
1667     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1668                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1669                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1670                || type == SVt_NV) {
1671         STORE_NUMERIC_LOCAL_SET_STANDARD();
1672         /* %Vg doesn't work? --jhi */
1673 #ifdef USE_LONG_DOUBLE
1674         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1675 #else
1676         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1677 #endif
1678         RESTORE_NUMERIC_LOCAL();
1679     }
1680
1681     if (SvROK(sv)) {
1682         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1683         if (nest < maxnest)
1684             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1685     }
1686
1687     if (type < SVt_PV) {
1688         SvREFCNT_dec(d);
1689         return;
1690     }
1691
1692     if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1693         if (SvPVX_const(sv)) {
1694             STRLEN delta;
1695             if (SvOOK(sv)) {
1696                 SvOOK_offset(sv, delta);
1697                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1698                                  (UV) delta);
1699             } else {
1700                 delta = 0;
1701             }
1702             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1703             if (SvOOK(sv)) {
1704                 PerlIO_printf(file, "( %s . ) ",
1705                               pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1706                                          pvlim));
1707             }
1708             PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1709             if (SvUTF8(sv)) /* the 6?  \x{....} */
1710                 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1711             PerlIO_printf(file, "\n");
1712             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1713             Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
1714         }
1715         else
1716             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1717     }
1718
1719     if (type >= SVt_PVMG) {
1720         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1721             HV * const ost = SvOURSTASH(sv);
1722             if (ost)
1723                 do_hv_dump(level, file, "  OURSTASH", ost);
1724         } else {
1725             if (SvMAGIC(sv))
1726                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1727         }
1728         if (SvSTASH(sv))
1729             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1730
1731         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1732             Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
1733             Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1734             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1735         }
1736     }
1737
1738     /* Dump type-specific SV fields */
1739
1740     switch (type) {
1741     case SVt_PVAV:
1742         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1743         if (AvARRAY(sv) != AvALLOC(sv)) {
1744             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1745             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1746         }
1747         else
1748             PerlIO_putc(file, '\n');
1749         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1750         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1751         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1752         sv_setpvs(d, "");
1753         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1754         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1755         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1756                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1757         if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1758             int count;
1759             for (count = 0; count <=  av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1760                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1761
1762                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1763                 if (elt)
1764                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1765             }
1766         }
1767         break;
1768     case SVt_PVHV:
1769         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1770         if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
1771             /* Show distribution of HEs in the ARRAY */
1772             int freq[200];
1773 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1774             int i;
1775             int max = 0;
1776             U32 pow2 = 2, keys = HvUSEDKEYS(sv);
1777             NV theoret, sum = 0;
1778
1779             PerlIO_printf(file, "  (");
1780             Zero(freq, FREQ_MAX + 1, int);
1781             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1782                 HE* h;
1783                 int count = 0;
1784                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1785                     count++;
1786                 if (count > FREQ_MAX)
1787                     count = FREQ_MAX;
1788                 freq[count]++;
1789                 if (max < count)
1790                     max = count;
1791             }
1792             for (i = 0; i <= max; i++) {
1793                 if (freq[i]) {
1794                     PerlIO_printf(file, "%d%s:%d", i,
1795                                   (i == FREQ_MAX) ? "+" : "",
1796                                   freq[i]);
1797                     if (i != max)
1798                         PerlIO_printf(file, ", ");
1799                 }
1800             }
1801             PerlIO_putc(file, ')');
1802             /* The "quality" of a hash is defined as the total number of
1803                comparisons needed to access every element once, relative
1804                to the expected number needed for a random hash.
1805
1806                The total number of comparisons is equal to the sum of
1807                the squares of the number of entries in each bucket.
1808                For a random hash of n keys into k buckets, the expected
1809                value is
1810                                 n + n(n-1)/2k
1811             */
1812
1813             for (i = max; i > 0; i--) { /* Precision: count down. */
1814                 sum += freq[i] * i * i;
1815             }
1816             while ((keys = keys >> 1))
1817                 pow2 = pow2 << 1;
1818             theoret = HvUSEDKEYS(sv);
1819             theoret += theoret * (theoret-1)/pow2;
1820             PerlIO_putc(file, '\n');
1821             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1822         }
1823         PerlIO_putc(file, '\n');
1824         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
1825         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1826         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1827         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1828         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1829         {
1830             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1831             if (mg && mg->mg_obj) {
1832                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1833             }
1834         }
1835         {
1836             const char * const hvname = HvNAME_get(sv);
1837             if (hvname)
1838                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1839         }
1840         if (SvOOK(sv)) {
1841             AV * const backrefs
1842                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1843             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1844             if (HvAUX(sv)->xhv_name_count)
1845                 Perl_dump_indent(aTHX_
1846                  level, file, "  NAMECOUNT = %"IVdf"\n",
1847                  (IV)HvAUX(sv)->xhv_name_count
1848                 );
1849             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1850                 const I32 count = HvAUX(sv)->xhv_name_count;
1851                 if (count) {
1852                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1853                     /* The starting point is the first element if count is
1854                        positive and the second element if count is negative. */
1855                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1856                         + (count < 0 ? 1 : 0);
1857                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1858                         + (count < 0 ? -count : count);
1859                     while (hekp < endp) {
1860                         if (*hekp) {
1861                             sv_catpvs(names, ", \"");
1862                             sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
1863                             sv_catpvs(names, "\"");
1864                         } else {
1865                             /* This should never happen. */
1866                             sv_catpvs(names, ", (null)");
1867                         }
1868                         ++hekp;
1869                     }
1870                     Perl_dump_indent(aTHX_
1871                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1872                     );
1873                 }
1874                 else
1875                     Perl_dump_indent(aTHX_
1876                      level, file, "  ENAME = \"%s\"\n", HvENAME_get(sv)
1877                     );
1878             }
1879             if (backrefs) {
1880                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1881                                  PTR2UV(backrefs));
1882                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1883                            dumpops, pvlim);
1884             }
1885             if (meta) {
1886                 /* FIXME - mro_algs kflags can signal a UTF-8 name.  */
1887                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1888                                  (int)meta->mro_which->length,
1889                                  meta->mro_which->name,
1890                                  PTR2UV(meta->mro_which));
1891                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1892                                  (UV)meta->cache_gen);
1893                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1894                                  (UV)meta->pkg_gen);
1895                 if (meta->mro_linear_all) {
1896                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1897                                  PTR2UV(meta->mro_linear_all));
1898                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1899                            dumpops, pvlim);
1900                 }
1901                 if (meta->mro_linear_current) {
1902                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1903                                  PTR2UV(meta->mro_linear_current));
1904                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1905                            dumpops, pvlim);
1906                 }
1907                 if (meta->mro_nextmethod) {
1908                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1909                                  PTR2UV(meta->mro_nextmethod));
1910                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1911                            dumpops, pvlim);
1912                 }
1913                 if (meta->isa) {
1914                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1915                                  PTR2UV(meta->isa));
1916                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1917                            dumpops, pvlim);
1918                 }
1919             }
1920         }
1921         if (nest < maxnest) {
1922             HV * const hv = MUTABLE_HV(sv);
1923             STRLEN i;
1924             HE *he;
1925
1926             if (HvARRAY(hv)) {
1927                 int count = maxnest - nest;
1928                 for (i=0; i <= HvMAX(hv); i++) {
1929                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1930                         U32 hash;
1931                         SV * keysv;
1932                         const char * keypv;
1933                         SV * elt;
1934                 STRLEN len;
1935
1936                         if (count-- <= 0) goto DONEHV;
1937
1938                         hash = HeHASH(he);
1939                         keysv = hv_iterkeysv(he);
1940                         keypv = SvPV_const(keysv, len);
1941                         elt = HeVAL(he);
1942
1943                 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1944                 if (SvUTF8(keysv))
1945                     PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1946                         if (HvEITER_get(hv) == he)
1947                             PerlIO_printf(file, "[CURRENT] ");
1948                 if (HeKREHASH(he))
1949                     PerlIO_printf(file, "[REHASH] ");
1950                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1951                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1952             }
1953                 }
1954               DONEHV:;
1955             }
1956         }
1957         break;
1958
1959     case SVt_PVCV:
1960         if (SvPOK(sv)) {
1961             STRLEN len;
1962             const char *const proto =  SvPV_const(sv, len);
1963             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1964                              (int) len, proto);
1965         }
1966         /* FALL THROUGH */
1967     case SVt_PVFM:
1968         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1969         if (!CvISXSUB(sv)) {
1970             if (CvSTART(sv)) {
1971                 Perl_dump_indent(aTHX_ level, file,
1972                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1973                                  PTR2UV(CvSTART(sv)),
1974                                  (IV)sequence_num(CvSTART(sv)));
1975             }
1976             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1977                              PTR2UV(CvROOT(sv)));
1978             if (CvROOT(sv) && dumpops) {
1979                 do_op_dump(level+1, file, CvROOT(sv));
1980             }
1981         } else {
1982             SV * const constant = cv_const_sv((const CV *)sv);
1983
1984             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1985
1986             if (constant) {
1987                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1988                                  " (CONST SV)\n",
1989                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1990                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1991                            pvlim);
1992             } else {
1993                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1994                                  (IV)CvXSUBANY(sv).any_i32);
1995             }
1996         }
1997         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1998         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1999         if (type == SVt_PVCV)
2000             Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
2001         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
2002         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
2003         if (type == SVt_PVFM)
2004             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
2005         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
2006         if (nest < maxnest) {
2007             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2008         }
2009         {
2010             const CV * const outside = CvOUTSIDE(sv);
2011             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
2012                         PTR2UV(outside),
2013                         (!outside ? "null"
2014                          : CvANON(outside) ? "ANON"
2015                          : (outside == PL_main_cv) ? "MAIN"
2016                          : CvUNIQUE(outside) ? "UNIQUE"
2017                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
2018         }
2019         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
2020             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2021         break;
2022
2023     case SVt_PVGV:
2024     case SVt_PVLV:
2025         if (type == SVt_PVLV) {
2026             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2027             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2028             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2029             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2030             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
2031                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2032                     dumpops, pvlim);
2033         }
2034         if (!isGV_with_GP(sv))
2035             break;
2036         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
2037         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2038         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2039         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2040         if (!GvGP(sv))
2041             break;
2042         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2043         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2044         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2045         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2046         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2047         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2048         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2049         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2050         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2051         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2052         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2053         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2054         break;
2055     case SVt_PVIO:
2056         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2057         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2058         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2059         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2060         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2061         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2062         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2063         if (IoTOP_NAME(sv))
2064             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2065         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2066             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2067         else {
2068             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2069                              PTR2UV(IoTOP_GV(sv)));
2070             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2071                         maxnest, dumpops, pvlim);
2072         }
2073         /* Source filters hide things that are not GVs in these three, so let's
2074            be careful out there.  */
2075         if (IoFMT_NAME(sv))
2076             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2077         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2078             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2079         else {
2080             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2081                              PTR2UV(IoFMT_GV(sv)));
2082             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2083                         maxnest, dumpops, pvlim);
2084         }
2085         if (IoBOTTOM_NAME(sv))
2086             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2087         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2088             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2089         else {
2090             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2091                              PTR2UV(IoBOTTOM_GV(sv)));
2092             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2093                         maxnest, dumpops, pvlim);
2094         }
2095         if (isPRINT(IoTYPE(sv)))
2096             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2097         else
2098             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2099         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2100         break;
2101     case SVt_REGEXP:
2102         {
2103             struct regexp * const r = (struct regexp *)SvANY(sv);
2104             flags = RX_EXTFLAGS((REGEXP*)sv);
2105             sv_setpv(d,"");
2106             append_flags(d, flags, regexp_flags_names);
2107             if (*(SvEND(d) - 1) == ',') {
2108                 SvCUR_set(d, SvCUR(d) - 1);
2109                 SvPVX(d)[SvCUR(d)] = '\0';
2110             }
2111             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2112                                 (UV)flags, SvPVX_const(d));
2113             Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2114                                 (UV)(r->intflags));
2115             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2116                                 (UV)(r->nparens));
2117             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2118                                 (UV)(r->lastparen));
2119             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2120                                 (UV)(r->lastcloseparen));
2121             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2122                                 (IV)(r->minlen));
2123             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2124                                 (IV)(r->minlenret));
2125             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2126                                 (UV)(r->gofs));
2127             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2128                                 (UV)(r->pre_prefix));
2129             Perl_dump_indent(aTHX_ level, file, "  SEEN_EVALS = %"UVuf"\n",
2130                                 (UV)(r->seen_evals));
2131             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2132                                 (IV)(r->sublen));
2133             if (r->subbeg)
2134                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2135                             PTR2UV(r->subbeg),
2136                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2137             else
2138                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2139             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf"\n",
2140                                 PTR2UV(r->engine));
2141             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2142                                 PTR2UV(r->mother_re));
2143             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2144                                 PTR2UV(r->paren_names));
2145             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2146                                 PTR2UV(r->substrs));
2147             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2148                                 PTR2UV(r->pprivate));
2149             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2150                                 PTR2UV(r->offs));
2151 #ifdef PERL_OLD_COPY_ON_WRITE
2152             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2153                                 PTR2UV(r->saved_copy));
2154 #endif
2155         }
2156         break;
2157     }
2158     SvREFCNT_dec(d);
2159 }
2160
2161 void
2162 Perl_sv_dump(pTHX_ SV *sv)
2163 {
2164     dVAR;
2165
2166     PERL_ARGS_ASSERT_SV_DUMP;
2167
2168     if (SvROK(sv))
2169         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2170     else
2171         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2172 }
2173
2174 int
2175 Perl_runops_debug(pTHX)
2176 {
2177     dVAR;
2178     if (!PL_op) {
2179         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2180         return 0;
2181     }
2182
2183     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2184     do {
2185         if (PL_debug) {
2186             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2187                 PerlIO_printf(Perl_debug_log,
2188                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2189                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2190                               PTR2UV(*PL_watchaddr));
2191             if (DEBUG_s_TEST_) {
2192                 if (DEBUG_v_TEST_) {
2193                     PerlIO_printf(Perl_debug_log, "\n");
2194                     deb_stack_all();
2195                 }
2196                 else
2197                     debstack();
2198             }
2199
2200
2201             if (DEBUG_t_TEST_) debop(PL_op);
2202             if (DEBUG_P_TEST_) debprof(PL_op);
2203         }
2204     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2205     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2206
2207     TAINT_NOT;
2208     return 0;
2209 }
2210
2211 I32
2212 Perl_debop(pTHX_ const OP *o)
2213 {
2214     dVAR;
2215
2216     PERL_ARGS_ASSERT_DEBOP;
2217
2218     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2219         return 0;
2220
2221     Perl_deb(aTHX_ "%s", OP_NAME(o));
2222     switch (o->op_type) {
2223     case OP_CONST:
2224     case OP_HINTSEVAL:
2225         /* With ITHREADS, consts are stored in the pad, and the right pad
2226          * may not be active here, so check.
2227          * Looks like only during compiling the pads are illegal.
2228          */
2229 #ifdef USE_ITHREADS
2230         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2231 #endif
2232             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2233         break;
2234     case OP_GVSV:
2235     case OP_GV:
2236         if (cGVOPo_gv) {
2237             SV * const sv = newSV(0);
2238 #ifdef PERL_MAD
2239             /* FIXME - is this making unwarranted assumptions about the
2240                UTF-8 cleanliness of the dump file handle?  */
2241             SvUTF8_on(sv);
2242 #endif
2243             gv_fullname3(sv, cGVOPo_gv, NULL);
2244             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2245             SvREFCNT_dec(sv);
2246         }
2247         else
2248             PerlIO_printf(Perl_debug_log, "(NULL)");
2249         break;
2250     case OP_PADSV:
2251     case OP_PADAV:
2252     case OP_PADHV:
2253         {
2254         /* print the lexical's name */
2255         CV * const cv = deb_curcv(cxstack_ix);
2256         SV *sv;
2257         if (cv) {
2258             AV * const padlist = CvPADLIST(cv);
2259             AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2260             sv = *av_fetch(comppad, o->op_targ, FALSE);
2261         } else
2262             sv = NULL;
2263         if (sv)
2264             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2265         else
2266             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2267         }
2268         break;
2269     default:
2270         break;
2271     }
2272     PerlIO_printf(Perl_debug_log, "\n");
2273     return 0;
2274 }
2275
2276 STATIC CV*
2277 S_deb_curcv(pTHX_ const I32 ix)
2278 {
2279     dVAR;
2280     const PERL_CONTEXT * const cx = &cxstack[ix];
2281     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2282         return cx->blk_sub.cv;
2283     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2284         return PL_compcv;
2285     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2286         return PL_main_cv;
2287     else if (ix <= 0)
2288         return NULL;
2289     else
2290         return deb_curcv(ix - 1);
2291 }
2292
2293 void
2294 Perl_watch(pTHX_ char **addr)
2295 {
2296     dVAR;
2297
2298     PERL_ARGS_ASSERT_WATCH;
2299
2300     PL_watchaddr = addr;
2301     PL_watchok = *addr;
2302     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2303         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2304 }
2305
2306 STATIC void
2307 S_debprof(pTHX_ const OP *o)
2308 {
2309     dVAR;
2310
2311     PERL_ARGS_ASSERT_DEBPROF;
2312
2313     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2314         return;
2315     if (!PL_profiledata)
2316         Newxz(PL_profiledata, MAXO, U32);
2317     ++PL_profiledata[o->op_type];
2318 }
2319
2320 void
2321 Perl_debprofdump(pTHX)
2322 {
2323     dVAR;
2324     unsigned i;
2325     if (!PL_profiledata)
2326         return;
2327     for (i = 0; i < MAXO; i++) {
2328         if (PL_profiledata[i])
2329             PerlIO_printf(Perl_debug_log,
2330                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2331                                        PL_op_name[i]);
2332     }
2333 }
2334
2335 #ifdef PERL_MAD
2336 /*
2337  *    XML variants of most of the above routines
2338  */
2339
2340 STATIC void
2341 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2342 {
2343     va_list args;
2344
2345     PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2346
2347     PerlIO_printf(file, "\n    ");
2348     va_start(args, pat);
2349     xmldump_vindent(level, file, pat, &args);
2350     va_end(args);
2351 }
2352
2353
2354 void
2355 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2356 {
2357     va_list args;
2358     PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2359     va_start(args, pat);
2360     xmldump_vindent(level, file, pat, &args);
2361     va_end(args);
2362 }
2363
2364 void
2365 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2366 {
2367     PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2368
2369     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2370     PerlIO_vprintf(file, pat, *args);
2371 }
2372
2373 void
2374 Perl_xmldump_all(pTHX)
2375 {
2376     xmldump_all_perl(FALSE);
2377 }
2378
2379 void
2380 Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
2381 {
2382     PerlIO_setlinebuf(PL_xmlfp);
2383     if (PL_main_root)
2384         op_xmldump(PL_main_root);
2385     /* someday we might call this, when it outputs XML: */
2386     /* xmldump_packsubs_perl(PL_defstash, justperl); */
2387     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2388         PerlIO_close(PL_xmlfp);
2389     PL_xmlfp = 0;
2390 }
2391
2392 void
2393 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2394 {
2395     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2396     xmldump_packsubs_perl(stash, FALSE);
2397 }
2398
2399 void
2400 Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2401 {
2402     I32 i;
2403     HE  *entry;
2404
2405     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
2406
2407     if (!HvARRAY(stash))
2408         return;
2409     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2410         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2411             GV *gv = MUTABLE_GV(HeVAL(entry));
2412             HV *hv;
2413             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2414                 continue;
2415             if (GvCVu(gv))
2416                 xmldump_sub_perl(gv, justperl);
2417             if (GvFORM(gv))
2418                 xmldump_form(gv);
2419             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2420                 && (hv = GvHV(gv)) && hv != PL_defstash)
2421                 xmldump_packsubs_perl(hv, justperl);    /* nested package */
2422         }
2423     }
2424 }
2425
2426 void
2427 Perl_xmldump_sub(pTHX_ const GV *gv)
2428 {
2429     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2430     xmldump_sub_perl(gv, FALSE);
2431 }
2432
2433 void
2434 Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2435 {
2436     SV * sv;
2437
2438     PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
2439
2440     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2441         return;
2442
2443     sv = sv_newmortal();
2444     gv_fullname3(sv, gv, NULL);
2445     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2446     if (CvXSUB(GvCV(gv)))
2447         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2448             PTR2UV(CvXSUB(GvCV(gv))),
2449             (int)CvXSUBANY(GvCV(gv)).any_i32);
2450     else if (CvROOT(GvCV(gv)))
2451         op_xmldump(CvROOT(GvCV(gv)));
2452     else
2453         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2454 }
2455
2456 void
2457 Perl_xmldump_form(pTHX_ const GV *gv)
2458 {
2459     SV * const sv = sv_newmortal();
2460
2461     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2462
2463     gv_fullname3(sv, gv, NULL);
2464     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2465     if (CvROOT(GvFORM(gv)))
2466         op_xmldump(CvROOT(GvFORM(gv)));
2467     else
2468         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2469 }
2470
2471 void
2472 Perl_xmldump_eval(pTHX)
2473 {
2474     op_xmldump(PL_eval_root);
2475 }
2476
2477 char *
2478 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2479 {
2480     PERL_ARGS_ASSERT_SV_CATXMLSV;
2481     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2482 }
2483
2484 char *
2485 Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2486 {
2487     PERL_ARGS_ASSERT_SV_CATXMLPV;
2488     return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2489 }
2490
2491 char *
2492 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2493 {
2494     unsigned int c;
2495     const char * const e = pv + len;
2496     const char * const start = pv;
2497     STRLEN dsvcur;
2498     STRLEN cl;
2499
2500     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2501
2502     sv_catpvs(dsv,"");
2503     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2504
2505   retry:
2506     while (pv < e) {
2507         if (utf8) {
2508             c = utf8_to_uvchr((U8*)pv, &cl);
2509             if (cl == 0) {
2510                 SvCUR(dsv) = dsvcur;
2511                 pv = start;
2512                 utf8 = 0;
2513                 goto retry;
2514             }
2515         }
2516         else
2517             c = (*pv & 255);
2518
2519         switch (c) {
2520         case 0x00:
2521         case 0x01:
2522         case 0x02:
2523         case 0x03:
2524         case 0x04:
2525         case 0x05:
2526         case 0x06:
2527         case 0x07:
2528         case 0x08:
2529         case 0x0b:
2530         case 0x0c:
2531         case 0x0e:
2532         case 0x0f:
2533         case 0x10:
2534         case 0x11:
2535         case 0x12:
2536         case 0x13:
2537         case 0x14:
2538         case 0x15:
2539         case 0x16:
2540         case 0x17:
2541         case 0x18:
2542         case 0x19:
2543         case 0x1a:
2544         case 0x1b:
2545         case 0x1c:
2546         case 0x1d:
2547         case 0x1e:
2548         case 0x1f:
2549         case 0x7f:
2550         case 0x80:
2551         case 0x81:
2552         case 0x82:
2553         case 0x83:
2554         case 0x84:
2555         case 0x86:
2556         case 0x87:
2557         case 0x88:
2558         case 0x89:
2559         case 0x90:
2560         case 0x91:
2561         case 0x92:
2562         case 0x93:
2563         case 0x94:
2564         case 0x95:
2565         case 0x96:
2566         case 0x97:
2567         case 0x98:
2568         case 0x99:
2569         case 0x9a:
2570         case 0x9b:
2571         case 0x9c:
2572         case 0x9d:
2573         case 0x9e:
2574         case 0x9f:
2575             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2576             break;
2577         case '<':
2578             sv_catpvs(dsv, "&lt;");
2579             break;
2580         case '>':
2581             sv_catpvs(dsv, "&gt;");
2582             break;
2583         case '&':
2584             sv_catpvs(dsv, "&amp;");
2585             break;
2586         case '"':
2587             sv_catpvs(dsv, "&#34;");
2588             break;
2589         default:
2590             if (c < 0xD800) {
2591                 if (c < 32 || c > 127) {
2592                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2593                 }
2594                 else {
2595                     const char string = (char) c;
2596                     sv_catpvn(dsv, &string, 1);
2597                 }
2598                 break;
2599             }
2600             if ((c >= 0xD800 && c <= 0xDB7F) ||
2601                 (c >= 0xDC00 && c <= 0xDFFF) ||
2602                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2603                  c > 0x10ffff)
2604                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2605             else
2606                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2607         }
2608
2609         if (utf8)
2610             pv += UTF8SKIP(pv);
2611         else
2612             pv++;
2613     }
2614
2615     return SvPVX(dsv);
2616 }
2617
2618 char *
2619 Perl_sv_xmlpeek(pTHX_ SV *sv)
2620 {
2621     SV * const t = sv_newmortal();
2622     STRLEN n_a;
2623     int unref = 0;
2624
2625     PERL_ARGS_ASSERT_SV_XMLPEEK;
2626
2627     sv_utf8_upgrade(t);
2628     sv_setpvs(t, "");
2629     /* retry: */
2630     if (!sv) {
2631         sv_catpv(t, "VOID=\"\"");
2632         goto finish;
2633     }
2634     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2635         sv_catpv(t, "WILD=\"\"");
2636         goto finish;
2637     }
2638     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2639         if (sv == &PL_sv_undef) {
2640             sv_catpv(t, "SV_UNDEF=\"1\"");
2641             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2642                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2643                 SvREADONLY(sv))
2644                 goto finish;
2645         }
2646         else if (sv == &PL_sv_no) {
2647             sv_catpv(t, "SV_NO=\"1\"");
2648             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2649                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2650                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2651                                   SVp_POK|SVp_NOK)) &&
2652                 SvCUR(sv) == 0 &&
2653                 SvNVX(sv) == 0.0)
2654                 goto finish;
2655         }
2656         else if (sv == &PL_sv_yes) {
2657             sv_catpv(t, "SV_YES=\"1\"");
2658             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2659                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2660                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2661                                   SVp_POK|SVp_NOK)) &&
2662                 SvCUR(sv) == 1 &&
2663                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2664                 SvNVX(sv) == 1.0)
2665                 goto finish;
2666         }
2667         else {
2668             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2669             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2670                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2671                 SvREADONLY(sv))
2672                 goto finish;
2673         }
2674         sv_catpv(t, " XXX=\"\" ");
2675     }
2676     else if (SvREFCNT(sv) == 0) {
2677         sv_catpv(t, " refcnt=\"0\"");
2678         unref++;
2679     }
2680     else if (DEBUG_R_TEST_) {
2681         int is_tmp = 0;
2682         I32 ix;
2683         /* is this SV on the tmps stack? */
2684         for (ix=PL_tmps_ix; ix>=0; ix--) {
2685             if (PL_tmps_stack[ix] == sv) {
2686                 is_tmp = 1;
2687                 break;
2688             }
2689         }
2690         if (SvREFCNT(sv) > 1)
2691             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2692                     is_tmp ? "T" : "");
2693         else if (is_tmp)
2694             sv_catpv(t, " DRT=\"<T>\"");
2695     }
2696
2697     if (SvROK(sv)) {
2698         sv_catpv(t, " ROK=\"\"");
2699     }
2700     switch (SvTYPE(sv)) {
2701     default:
2702         sv_catpv(t, " FREED=\"1\"");
2703         goto finish;
2704
2705     case SVt_NULL:
2706         sv_catpv(t, " UNDEF=\"1\"");
2707         goto finish;
2708     case SVt_IV:
2709         sv_catpv(t, " IV=\"");
2710         break;
2711     case SVt_NV:
2712         sv_catpv(t, " NV=\"");
2713         break;
2714     case SVt_PV:
2715         sv_catpv(t, " PV=\"");
2716         break;
2717     case SVt_PVIV:
2718         sv_catpv(t, " PVIV=\"");
2719         break;
2720     case SVt_PVNV:
2721         sv_catpv(t, " PVNV=\"");
2722         break;
2723     case SVt_PVMG:
2724         sv_catpv(t, " PVMG=\"");
2725         break;
2726     case SVt_PVLV:
2727         sv_catpv(t, " PVLV=\"");
2728         break;
2729     case SVt_PVAV:
2730         sv_catpv(t, " AV=\"");
2731         break;
2732     case SVt_PVHV:
2733         sv_catpv(t, " HV=\"");
2734         break;
2735     case SVt_PVCV:
2736         if (CvGV(sv))
2737             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2738         else
2739             sv_catpv(t, " CV=\"()\"");
2740         goto finish;
2741     case SVt_PVGV:
2742         sv_catpv(t, " GV=\"");
2743         break;
2744     case SVt_BIND:
2745         sv_catpv(t, " BIND=\"");
2746         break;
2747     case SVt_REGEXP:
2748         sv_catpv(t, " REGEXP=\"");
2749         break;
2750     case SVt_PVFM:
2751         sv_catpv(t, " FM=\"");
2752         break;
2753     case SVt_PVIO:
2754         sv_catpv(t, " IO=\"");
2755         break;
2756     }
2757
2758     if (SvPOKp(sv)) {
2759         if (SvPVX(sv)) {
2760             sv_catxmlsv(t, sv);
2761         }
2762     }
2763     else if (SvNOKp(sv)) {
2764         STORE_NUMERIC_LOCAL_SET_STANDARD();
2765         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2766         RESTORE_NUMERIC_LOCAL();
2767     }
2768     else if (SvIOKp(sv)) {
2769         if (SvIsUV(sv))
2770             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2771         else
2772             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2773     }
2774     else
2775         sv_catpv(t, "");
2776     sv_catpv(t, "\"");
2777
2778   finish:
2779     while (unref--)
2780         sv_catpv(t, ")");
2781     return SvPV(t, n_a);
2782 }
2783
2784 void
2785 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2786 {
2787     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2788
2789     if (!pm) {
2790         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2791         return;
2792     }
2793     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2794     level++;
2795     if (PM_GETRE(pm)) {
2796         REGEXP *const r = PM_GETRE(pm);
2797         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2798         sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2799         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2800              SvPVX(tmpsv));
2801         SvREFCNT_dec(tmpsv);
2802         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2803              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2804     }
2805     else
2806         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2807     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2808         SV * const tmpsv = pm_description(pm);
2809         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2810         SvREFCNT_dec(tmpsv);
2811     }
2812
2813     level--;
2814     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2815         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2816         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2817         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2818         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2819         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2820     }
2821     else
2822         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2823 }
2824
2825 void
2826 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2827 {
2828     do_pmop_xmldump(0, PL_xmlfp, pm);
2829 }
2830
2831 void
2832 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2833 {
2834     UV      seq;
2835     int     contents = 0;
2836
2837     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2838
2839     if (!o)
2840         return;
2841     sequence(o);
2842     seq = sequence_num(o);
2843     Perl_xmldump_indent(aTHX_ level, file,
2844         "<op_%s seq=\"%"UVuf" -> ",
2845              OP_NAME(o),
2846                       seq);
2847     level++;
2848     if (o->op_next)
2849         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2850                       sequence_num(o->op_next));
2851     else
2852         PerlIO_printf(file, "DONE\"");
2853
2854     if (o->op_targ) {
2855         if (o->op_type == OP_NULL)
2856         {
2857             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2858             if (o->op_targ == OP_NEXTSTATE)
2859             {
2860                 if (CopLINE(cCOPo))
2861                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2862                                      (UV)CopLINE(cCOPo));
2863                 if (CopSTASHPV(cCOPo))
2864                     PerlIO_printf(file, " package=\"%s\"",
2865                                      CopSTASHPV(cCOPo));
2866                 if (CopLABEL(cCOPo))
2867                     PerlIO_printf(file, " label=\"%s\"",
2868                                      CopLABEL(cCOPo));
2869             }
2870         }
2871         else
2872             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2873     }
2874 #ifdef DUMPADDR
2875     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2876 #endif
2877     if (o->op_flags) {
2878         SV * const tmpsv = newSVpvs("");
2879         switch (o->op_flags & OPf_WANT) {
2880         case OPf_WANT_VOID:
2881             sv_catpv(tmpsv, ",VOID");
2882             break;
2883         case OPf_WANT_SCALAR:
2884             sv_catpv(tmpsv, ",SCALAR");
2885             break;
2886         case OPf_WANT_LIST:
2887             sv_catpv(tmpsv, ",LIST");
2888             break;
2889         default:
2890             sv_catpv(tmpsv, ",UNKNOWN");
2891             break;
2892         }
2893         if (o->op_flags & OPf_KIDS)
2894             sv_catpv(tmpsv, ",KIDS");
2895         if (o->op_flags & OPf_PARENS)
2896             sv_catpv(tmpsv, ",PARENS");
2897         if (o->op_flags & OPf_STACKED)
2898             sv_catpv(tmpsv, ",STACKED");
2899         if (o->op_flags & OPf_REF)
2900             sv_catpv(tmpsv, ",REF");
2901         if (o->op_flags & OPf_MOD)
2902             sv_catpv(tmpsv, ",MOD");
2903         if (o->op_flags & OPf_SPECIAL)
2904             sv_catpv(tmpsv, ",SPECIAL");
2905         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2906         SvREFCNT_dec(tmpsv);
2907     }
2908     if (o->op_private) {
2909         SV * const tmpsv = newSVpvs("");
2910         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2911             if (o->op_private & OPpTARGET_MY)
2912                 sv_catpv(tmpsv, ",TARGET_MY");
2913         }
2914         else if (o->op_type == OP_LEAVESUB ||
2915                  o->op_type == OP_LEAVE ||
2916                  o->op_type == OP_LEAVESUBLV ||
2917                  o->op_type == OP_LEAVEWRITE) {
2918             if (o->op_private & OPpREFCOUNTED)
2919                 sv_catpv(tmpsv, ",REFCOUNTED");
2920         }
2921         else if (o->op_type == OP_AASSIGN) {
2922             if (o->op_private & OPpASSIGN_COMMON)
2923                 sv_catpv(tmpsv, ",COMMON");
2924         }
2925         else if (o->op_type == OP_SASSIGN) {
2926             if (o->op_private & OPpASSIGN_BACKWARDS)
2927                 sv_catpv(tmpsv, ",BACKWARDS");
2928         }
2929         else if (o->op_type == OP_TRANS) {
2930             if (o->op_private & OPpTRANS_SQUASH)
2931                 sv_catpv(tmpsv, ",SQUASH");
2932             if (o->op_private & OPpTRANS_DELETE)
2933                 sv_catpv(tmpsv, ",DELETE");
2934             if (o->op_private & OPpTRANS_COMPLEMENT)
2935                 sv_catpv(tmpsv, ",COMPLEMENT");
2936             if (o->op_private & OPpTRANS_IDENTICAL)
2937                 sv_catpv(tmpsv, ",IDENTICAL");
2938             if (o->op_private & OPpTRANS_GROWS)
2939                 sv_catpv(tmpsv, ",GROWS");
2940         }
2941         else if (o->op_type == OP_REPEAT) {
2942             if (o->op_private & OPpREPEAT_DOLIST)
2943                 sv_catpv(tmpsv, ",DOLIST");
2944         }
2945         else if (o->op_type == OP_ENTERSUB ||
2946                  o->op_type == OP_RV2SV ||
2947                  o->op_type == OP_GVSV ||
2948                  o->op_type == OP_RV2AV ||
2949                  o->op_type == OP_RV2HV ||
2950                  o->op_type == OP_RV2GV ||
2951                  o->op_type == OP_AELEM ||
2952                  o->op_type == OP_HELEM )
2953         {
2954             if (o->op_type == OP_ENTERSUB) {
2955                 if (o->op_private & OPpENTERSUB_AMPER)
2956                     sv_catpv(tmpsv, ",AMPER");
2957                 if (o->op_private & OPpENTERSUB_DB)
2958                     sv_catpv(tmpsv, ",DB");
2959                 if (o->op_private & OPpENTERSUB_HASTARG)
2960                     sv_catpv(tmpsv, ",HASTARG");
2961                 if (o->op_private & OPpENTERSUB_NOPAREN)
2962                     sv_catpv(tmpsv, ",NOPAREN");
2963                 if (o->op_private & OPpENTERSUB_INARGS)
2964                     sv_catpv(tmpsv, ",INARGS");
2965                 if (o->op_private & OPpENTERSUB_NOMOD)
2966                     sv_catpv(tmpsv, ",NOMOD");
2967             }
2968             else {
2969                 switch (o->op_private & OPpDEREF) {
2970             case OPpDEREF_SV:
2971                 sv_catpv(tmpsv, ",SV");
2972                 break;
2973             case OPpDEREF_AV:
2974                 sv_catpv(tmpsv, ",AV");
2975                 break;
2976             case OPpDEREF_HV:
2977                 sv_catpv(tmpsv, ",HV");
2978                 break;
2979             }
2980                 if (o->op_private & OPpMAYBE_LVSUB)
2981                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2982             }
2983             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2984                 if (o->op_private & OPpLVAL_DEFER)
2985                     sv_catpv(tmpsv, ",LVAL_DEFER");
2986             }
2987             else {
2988                 if (o->op_private & HINT_STRICT_REFS)
2989                     sv_catpv(tmpsv, ",STRICT_REFS");
2990                 if (o->op_private & OPpOUR_INTRO)
2991                     sv_catpv(tmpsv, ",OUR_INTRO");
2992             }
2993         }
2994         else if (o->op_type == OP_CONST) {
2995             if (o->op_private & OPpCONST_BARE)
2996                 sv_catpv(tmpsv, ",BARE");
2997             if (o->op_private & OPpCONST_STRICT)
2998                 sv_catpv(tmpsv, ",STRICT");
2999             if (o->op_private & OPpCONST_ARYBASE)
3000                 sv_catpv(tmpsv, ",ARYBASE");
3001             if (o->op_private & OPpCONST_WARNING)
3002                 sv_catpv(tmpsv, ",WARNING");
3003             if (o->op_private & OPpCONST_ENTERED)
3004                 sv_catpv(tmpsv, ",ENTERED");
3005         }
3006         else if (o->op_type == OP_FLIP) {
3007             if (o->op_private & OPpFLIP_LINENUM)
3008                 sv_catpv(tmpsv, ",LINENUM");
3009         }
3010         else if (o->op_type == OP_FLOP) {
3011             if (o->op_private & OPpFLIP_LINENUM)
3012                 sv_catpv(tmpsv, ",LINENUM");
3013         }
3014         else if (o->op_type == OP_RV2CV) {
3015             if (o->op_private & OPpLVAL_INTRO)
3016                 sv_catpv(tmpsv, ",INTRO");
3017         }
3018         else if (o->op_type == OP_GV) {
3019             if (o->op_private & OPpEARLY_CV)
3020                 sv_catpv(tmpsv, ",EARLY_CV");
3021         }
3022         else if (o->op_type == OP_LIST) {
3023             if (o->op_private & OPpLIST_GUESSED)
3024                 sv_catpv(tmpsv, ",GUESSED");
3025         }
3026         else if (o->op_type == OP_DELETE) {
3027             if (o->op_private & OPpSLICE)
3028                 sv_catpv(tmpsv, ",SLICE");
3029         }
3030         else if (o->op_type == OP_EXISTS) {
3031             if (o->op_private & OPpEXISTS_SUB)
3032                 sv_catpv(tmpsv, ",EXISTS_SUB");
3033         }
3034         else if (o->op_type == OP_SORT) {
3035             if (o->op_private & OPpSORT_NUMERIC)
3036                 sv_catpv(tmpsv, ",NUMERIC");
3037             if (o->op_private & OPpSORT_INTEGER)
3038                 sv_catpv(tmpsv, ",INTEGER");
3039             if (o->op_private & OPpSORT_REVERSE)
3040                 sv_catpv(tmpsv, ",REVERSE");
3041         }
3042         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
3043             if (o->op_private & OPpOPEN_IN_RAW)
3044                 sv_catpv(tmpsv, ",IN_RAW");
3045             if (o->op_private & OPpOPEN_IN_CRLF)
3046                 sv_catpv(tmpsv, ",IN_CRLF");
3047             if (o->op_private & OPpOPEN_OUT_RAW)
3048                 sv_catpv(tmpsv, ",OUT_RAW");
3049             if (o->op_private & OPpOPEN_OUT_CRLF)
3050                 sv_catpv(tmpsv, ",OUT_CRLF");
3051         }
3052         else if (o->op_type == OP_EXIT) {
3053             if (o->op_private & OPpEXIT_VMSISH)
3054                 sv_catpv(tmpsv, ",EXIT_VMSISH");
3055             if (o->op_private & OPpHUSH_VMSISH)
3056                 sv_catpv(tmpsv, ",HUSH_VMSISH");
3057         }
3058         else if (o->op_type == OP_DIE) {
3059             if (o->op_private & OPpHUSH_VMSISH)
3060                 sv_catpv(tmpsv, ",HUSH_VMSISH");
3061         }
3062         else if (PL_check[o->op_type] != Perl_ck_ftst) {
3063             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
3064                 sv_catpv(tmpsv, ",FT_ACCESS");
3065             if (o->op_private & OPpFT_STACKED)
3066                 sv_catpv(tmpsv, ",FT_STACKED");
3067         }
3068         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
3069             sv_catpv(tmpsv, ",INTRO");
3070         if (SvCUR(tmpsv))
3071             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
3072         SvREFCNT_dec(tmpsv);
3073     }
3074
3075     switch (o->op_type) {
3076     case OP_AELEMFAST:
3077         if (o->op_flags & OPf_SPECIAL) {
3078             break;
3079         }
3080     case OP_GVSV:
3081     case OP_GV:
3082 #ifdef USE_ITHREADS
3083         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3084 #else
3085         if (cSVOPo->op_sv) {
3086             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3087             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3088             char *s;
3089             STRLEN len;
3090             ENTER;
3091             SAVEFREESV(tmpsv1);
3092             SAVEFREESV(tmpsv2);
3093             gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3094             s = SvPV(tmpsv1,len);
3095             sv_catxmlpvn(tmpsv2, s, len, 1);
3096             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3097             LEAVE;
3098         }
3099         else
3100             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3101 #endif
3102         break;
3103     case OP_CONST:
3104     case OP_HINTSEVAL:
3105     case OP_METHOD_NAMED:
3106 #ifndef USE_ITHREADS
3107         /* with ITHREADS, consts are stored in the pad, and the right pad
3108          * may not be active here, so skip */
3109         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3110 #endif
3111         break;
3112     case OP_ANONCODE:
3113         if (!contents) {
3114             contents = 1;
3115             PerlIO_printf(file, ">\n");
3116         }
3117         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3118         break;
3119     case OP_NEXTSTATE:
3120     case OP_DBSTATE:
3121         if (CopLINE(cCOPo))
3122             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3123                              (UV)CopLINE(cCOPo));
3124         if (CopSTASHPV(cCOPo))
3125             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3126                              CopSTASHPV(cCOPo));
3127         if (CopLABEL(cCOPo))
3128             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
3129                              CopLABEL(cCOPo));
3130         break;
3131     case OP_ENTERLOOP:
3132         S_xmldump_attr(aTHX_ level, file, "redo=\"");
3133         if (cLOOPo->op_redoop)
3134             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3135         else
3136             PerlIO_printf(file, "DONE\"");
3137         S_xmldump_attr(aTHX_ level, file, "next=\"");
3138         if (cLOOPo->op_nextop)
3139             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3140         else
3141             PerlIO_printf(file, "DONE\"");
3142         S_xmldump_attr(aTHX_ level, file, "last=\"");
3143         if (cLOOPo->op_lastop)
3144             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3145         else
3146             PerlIO_printf(file, "DONE\"");
3147         break;
3148     case OP_COND_EXPR:
3149     case OP_RANGE:
3150     case OP_MAPWHILE:
3151     case OP_GREPWHILE:
3152     case OP_OR:
3153     case OP_AND:
3154         S_xmldump_attr(aTHX_ level, file, "other=\"");
3155         if (cLOGOPo->op_other)
3156             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3157         else
3158             PerlIO_printf(file, "DONE\"");
3159         break;
3160     case OP_LEAVE:
3161     case OP_LEAVEEVAL:
3162     case OP_LEAVESUB:
3163     case OP_LEAVESUBLV:
3164     case OP_LEAVEWRITE:
3165     case OP_SCOPE:
3166         if (o->op_private & OPpREFCOUNTED)
3167             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3168         break;
3169     default:
3170         break;
3171     }
3172
3173     if (PL_madskills && o->op_madprop) {
3174         char prevkey = '\0';
3175         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
3176         const MADPROP* mp = o->op_madprop;
3177
3178         if (!contents) {
3179             contents = 1;
3180             PerlIO_printf(file, ">\n");
3181         }
3182         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3183         level++;
3184         while (mp) {
3185             char tmp = mp->mad_key;
3186             sv_setpvs(tmpsv,"\"");
3187             if (tmp)
3188                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
3189             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3190                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3191             else
3192                 prevkey = tmp;
3193             sv_catpv(tmpsv, "\"");
3194             switch (mp->mad_type) {
3195             case MAD_NULL:
3196                 sv_catpv(tmpsv, "NULL");
3197                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3198                 break;
3199             case MAD_PV:
3200                 sv_catpv(tmpsv, " val=\"");
3201                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3202                 sv_catpv(tmpsv, "\"");
3203                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3204                 break;
3205             case MAD_SV:
3206                 sv_catpv(tmpsv, " val=\"");
3207                 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3208                 sv_catpv(tmpsv, "\"");
3209                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3210                 break;
3211             case MAD_OP:
3212                 if ((OP*)mp->mad_val) {
3213                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3214                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3215                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3216                 }
3217                 break;
3218             default:
3219                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3220                 break;
3221             }
3222             mp = mp->mad_next;
3223         }
3224         level--;
3225         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3226
3227         SvREFCNT_dec(tmpsv);
3228     }
3229
3230     switch (o->op_type) {
3231     case OP_PUSHRE:
3232     case OP_MATCH:
3233     case OP_QR:
3234     case OP_SUBST:
3235         if (!contents) {
3236             contents = 1;
3237             PerlIO_printf(file, ">\n");
3238         }
3239         do_pmop_xmldump(level, file, cPMOPo);
3240         break;
3241     default:
3242         break;
3243     }
3244
3245     if (o->op_flags & OPf_KIDS) {
3246         OP *kid;
3247         if (!contents) {
3248             contents = 1;
3249             PerlIO_printf(file, ">\n");
3250         }
3251         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3252             do_op_xmldump(level, file, kid);
3253     }
3254
3255     if (contents)
3256         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3257     else
3258         PerlIO_printf(file, " />\n");
3259 }
3260
3261 void
3262 Perl_op_xmldump(pTHX_ const OP *o)
3263 {
3264     PERL_ARGS_ASSERT_OP_XMLDUMP;
3265
3266     do_op_xmldump(0, PL_xmlfp, o);
3267 }
3268 #endif
3269
3270 /*
3271  * Local variables:
3272  * c-indentation-style: bsd
3273  * c-basic-offset: 4
3274  * indent-tabs-mode: t
3275  * End:
3276  *
3277  * ex: set ts=8 sts=4 sw=4 noet:
3278  */