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