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