dump.c

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