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 =head1 Display and Dump functions
  25  */
  26
  27 #include "EXTERN.h"
  28 #define PERL_IN_DUMP_C
  29 #include "perl.h"
  30 #include "regcomp.h"
  31
  32 static const char* const svtypenames[SVt_LAST] = {
  33     "NULL",
  34     "IV",
  35     "NV",
  36     "PV",
  37     "INVLIST",
  38     "PVIV",
  39     "PVNV",
  40     "PVMG",
  41     "REGEXP",
  42     "PVGV",
  43     "PVLV",
  44     "PVAV",
  45     "PVHV",
  46     "PVCV",
  47     "PVFM",
  48     "PVIO"
  49 };
  50
  51
  52 static const char* const svshorttypenames[SVt_LAST] = {
  53     "UNDEF",
  54     "IV",
  55     "NV",
  56     "PV",
  57     "INVLST",
  58     "PVIV",
  59     "PVNV",
  60     "PVMG",
  61     "REGEXP",
  62     "GV",
  63     "PVLV",
  64     "AV",
  65     "HV",
  66     "CV",
  67     "FM",
  68     "IO"
  69 };
  70
  71 struct flag_to_name {
  72     U32 flag;
  73     const char *name;
  74 };
  75
  76 static void
  77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
  78                const struct flag_to_name *const end)
  79 {
  80     do {
  81         if (flags & start->flag)
  82             sv_catpv(sv, start->name);
  83     } while (++start < end);
  84 }
  85
  86 #define append_flags(sv, f, flags) \
  87     S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
  88
  89 #define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
  90                               (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
  91                               PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
  92                               | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
  93
  94 /*
  95 =for apidoc pv_escape
  96
  97 Escapes at most the first C<count> chars of C<pv> and puts the results into
  98 C<dsv> such that the size of the escaped string will not exceed C<max> chars
  99 and will not contain any incomplete escape sequences.  The number of bytes
 100 escaped will be returned in the C<STRLEN *escaped> parameter if it is not null.
 101 When the C<dsv> parameter is null no escaping actually occurs, but the number
 102 of bytes that would be escaped were it not null will be calculated.
 103
 104 If flags contains C<PERL_PV_ESCAPE_QUOTE> then any double quotes in the string
 105 will also be escaped.
 106
 107 Normally the SV will be cleared before the escaped string is prepared,
 108 but when C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur.
 109
 110 If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8
 111 if C<PERL_PV_ESCAPE_UNI_DETECT> is set then the input string is scanned
 112 using C<is_utf8_string()> to determine if it is UTF-8.
 113
 114 If C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output
 115 using C<\x01F1> style escapes, otherwise if C<PERL_PV_ESCAPE_NONASCII> is set, only
 116 non-ASCII chars will be escaped using this style; otherwise, only chars above
 117 255 will be so escaped; other non printable chars will use octal or
 118 common escaped patterns like C<\n>.
 119 Otherwise, if C<PERL_PV_ESCAPE_NOBACKSLASH>
 120 then all chars below 255 will be treated as printable and
 121 will be output as literals.
 122
 123 If C<PERL_PV_ESCAPE_FIRSTCHAR> is set then only the first char of the
 124 string will be escaped, regardless of max.  If the output is to be in hex,
 125 then it will be returned as a plain hex
 126 sequence.  Thus the output will either be a single char,
 127 an octal escape sequence, a special escape like C<\n> or a hex value.
 128
 129 If C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a C<"%"> and
 130 not a C<"\\">.  This is because regexes very often contain backslashed
 131 sequences, whereas C<"%"> is not a particularly common character in patterns.
 132
 133 Returns a pointer to the escaped text as held by C<dsv>.
 134
 135 =cut
 136 */
 137 #define PV_ESCAPE_OCTBUFSIZE 32
 138
 139 char *
 140 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
 141                 const STRLEN count, const STRLEN max,
 142                 STRLEN * const escaped, const U32 flags )
 143 {
 144     const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
 145     const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
 146     char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
 147     STRLEN wrote = 0;    /* chars written so far */
 148     STRLEN chsize = 0;   /* size of data to be written */
 149     STRLEN readsize = 1; /* size of data just read */
 150     bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this UTF-8 */
 151     const char *pv  = str;
 152     const char * const end = pv + count; /* end of string */
 153     octbuf[0] = esc;
 154
 155     PERL_ARGS_ASSERT_PV_ESCAPE;
 156
 157     if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
 158             /* This won't alter the UTF-8 flag */
 159             SvPVCLEAR(dsv);
 160     }
 161
 162     if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
 163         isuni = 1;
 164
 165     for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
 166         const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
 167         const U8 c = (U8)u & 0xFF;
 168
 169         if ( ( u > 255 )
 170           || (flags & PERL_PV_ESCAPE_ALL)
 171           || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
 172         {
 173             if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
 174                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 175                                       "%"UVxf, u);
 176             else
 177                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 178                                       ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
 179                                       ? "%cx%02"UVxf
 180                                       : "%cx{%02"UVxf"}", esc, u);
 181
 182         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
 183             chsize = 1;
 184         } else {
 185             if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
 186                 chsize = 2;
 187                 switch (c) {
 188
 189                 case '\\' : /* FALLTHROUGH */
 190                 case '%'  : if ( c == esc )  {
 191                                 octbuf[1] = esc;
 192                             } else {
 193                                 chsize = 1;
 194                             }
 195                             break;
 196                 case '\v' : octbuf[1] = 'v';  break;
 197                 case '\t' : octbuf[1] = 't';  break;
 198                 case '\r' : octbuf[1] = 'r';  break;
 199                 case '\n' : octbuf[1] = 'n';  break;
 200                 case '\f' : octbuf[1] = 'f';  break;
 201                 case '"'  :
 202                         if ( dq == '"' )
 203                                 octbuf[1] = '"';
 204                         else
 205                             chsize = 1;
 206                         break;
 207                 default:
 208                      if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
 209                         chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 210                                       isuni ? "%cx{%02"UVxf"}" : "%cx%02"UVxf,
 211                                       esc, u);
 212                      }
 213                      else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
 214                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 215                                                   "%c%03o", esc, c);
 216                         else
 217                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 218                                                   "%c%o", esc, c);
 219                 }
 220             } else {
 221                 chsize = 1;
 222             }
 223         }
 224         if ( max && (wrote + chsize > max) ) {
 225             break;
 226         } else if (chsize > 1) {
 227             if (dsv)
 228                 sv_catpvn(dsv, octbuf, chsize);
 229             wrote += chsize;
 230         } else {
 231             /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
 232                can be appended raw to the dsv. If dsv happens to be
 233                UTF-8 then we need catpvf to upgrade them for us.
 234                Or add a new API call sv_catpvc(). Think about that name, and
 235                how to keep it clear that it's unlike the s of catpvs, which is
 236                really an array of octets, not a string.  */
 237             if (dsv)
 238                 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
 239             wrote++;
 240         }
 241         if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
 242             break;
 243     }
 244     if (escaped != NULL)
 245         *escaped= pv - str;
 246     return dsv ? SvPVX(dsv) : NULL;
 247 }
 248 /*
 249 =for apidoc pv_pretty
 250
 251 Converts a string into something presentable, handling escaping via
 252 C<pv_escape()> and supporting quoting and ellipses.
 253
 254 If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be
 255 double quoted with any double quotes in the string escaped.  Otherwise
 256 if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
 257 angle brackets.
 258
 259 If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in
 260 string were output then an ellipsis C<...> will be appended to the
 261 string.  Note that this happens AFTER it has been quoted.
 262
 263 If C<start_color> is non-null then it will be inserted after the opening
 264 quote (if there is one) but before the escaped text.  If C<end_color>
 265 is non-null then it will be inserted after the escaped text but before
 266 any quotes or ellipses.
 267
 268 Returns a pointer to the prettified text as held by C<dsv>.
 269
 270 =cut
 271 */
 272
 273 char *
 274 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
 275   const STRLEN max, char const * const start_color, char const * const end_color,
 276   const U32 flags )
 277 {
 278     const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
 279                              (flags & PERL_PV_PRETTY_LTGT)  ? "<>" : NULL);
 280     STRLEN escaped;
 281     STRLEN max_adjust= 0;
 282     STRLEN orig_cur;
 283
 284     PERL_ARGS_ASSERT_PV_PRETTY;
 285
 286     if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
 287         /* This won't alter the UTF-8 flag */
 288         SvPVCLEAR(dsv);
 289     }
 290     orig_cur= SvCUR(dsv);
 291
 292     if ( quotes )
 293         Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
 294
 295     if ( start_color != NULL )
 296         sv_catpv(dsv, start_color);
 297
 298     if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
 299         if (quotes)
 300             max_adjust += 2;
 301         assert(max > max_adjust);
 302         pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
 303         if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
 304             max_adjust += 3;
 305         assert(max > max_adjust);
 306     }
 307
 308     pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
 309
 310     if ( end_color != NULL )
 311         sv_catpv(dsv, end_color);
 312
 313     if ( quotes )
 314         Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
 315
 316     if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
 317             sv_catpvs(dsv, "...");
 318
 319     if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
 320         while( SvCUR(dsv) - orig_cur < max )
 321             sv_catpvs(dsv," ");
 322     }
 323
 324     return SvPVX(dsv);
 325 }
 326
 327 /*
 328 =for apidoc pv_display
 329
 330 Similar to
 331
 332   pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
 333
 334 except that an additional "\0" will be appended to the string when
 335 len > cur and pv[cur] is "\0".
 336
 337 Note that the final string may be up to 7 chars longer than pvlim.
 338
 339 =cut
 340 */
 341
 342 char *
 343 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
 344 {
 345     PERL_ARGS_ASSERT_PV_DISPLAY;
 346
 347     pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
 348     if (len > cur && pv[cur] == '\0')
 349             sv_catpvs( dsv, "\\0");
 350     return SvPVX(dsv);
 351 }
 352
 353 char *
 354 Perl_sv_peek(pTHX_ SV *sv)
 355 {
 356     dVAR;
 357     SV * const t = sv_newmortal();
 358     int unref = 0;
 359     U32 type;
 360
 361     SvPVCLEAR(t);
 362   retry:
 363     if (!sv) {
 364         sv_catpv(t, "VOID");
 365         goto finish;
 366     }
 367     else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
 368         /* detect data corruption under memory poisoning */
 369         sv_catpv(t, "WILD");
 370         goto finish;
 371     }
 372     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
 373         if (sv == &PL_sv_undef) {
 374             sv_catpv(t, "SV_UNDEF");
 375             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 376                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 377                 SvREADONLY(sv))
 378                 goto finish;
 379         }
 380         else if (sv == &PL_sv_no) {
 381             sv_catpv(t, "SV_NO");
 382             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 383                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 384                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 385                                   SVp_POK|SVp_NOK)) &&
 386                 SvCUR(sv) == 0 &&
 387                 SvNVX(sv) == 0.0)
 388                 goto finish;
 389         }
 390         else if (sv == &PL_sv_yes) {
 391             sv_catpv(t, "SV_YES");
 392             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 393                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 394                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 395                                   SVp_POK|SVp_NOK)) &&
 396                 SvCUR(sv) == 1 &&
 397                 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
 398                 SvNVX(sv) == 1.0)
 399                 goto finish;
 400         }
 401         else {
 402             sv_catpv(t, "SV_PLACEHOLDER");
 403             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 404                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 405                 SvREADONLY(sv))
 406                 goto finish;
 407         }
 408         sv_catpv(t, ":");
 409     }
 410     else if (SvREFCNT(sv) == 0) {
 411         sv_catpv(t, "(");
 412         unref++;
 413     }
 414     else if (DEBUG_R_TEST_) {
 415         int is_tmp = 0;
 416         SSize_t ix;
 417         /* is this SV on the tmps stack? */
 418         for (ix=PL_tmps_ix; ix>=0; ix--) {
 419             if (PL_tmps_stack[ix] == sv) {
 420                 is_tmp = 1;
 421                 break;
 422             }
 423         }
 424         if (is_tmp || SvREFCNT(sv) > 1) {
 425             Perl_sv_catpvf(aTHX_ t, "<");
 426             if (SvREFCNT(sv) > 1)
 427                 Perl_sv_catpvf(aTHX_ t, "%"UVuf, (UV)SvREFCNT(sv));
 428             if (is_tmp)
 429                 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
 430             Perl_sv_catpvf(aTHX_ t, ">");
 431         }
 432     }
 433
 434     if (SvROK(sv)) {
 435         sv_catpv(t, "\\");
 436         if (SvCUR(t) + unref > 10) {
 437             SvCUR_set(t, unref + 3);
 438             *SvEND(t) = '\0';
 439             sv_catpv(t, "...");
 440             goto finish;
 441         }
 442         sv = SvRV(sv);
 443         goto retry;
 444     }
 445     type = SvTYPE(sv);
 446     if (type == SVt_PVCV) {
 447         SV * const tmp = newSVpvs_flags("", SVs_TEMP);
 448         GV* gvcv = CvGV(sv);
 449         Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
 450                        ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
 451                        : "");
 452         goto finish;
 453     } else if (type < SVt_LAST) {
 454         sv_catpv(t, svshorttypenames[type]);
 455
 456         if (type == SVt_NULL)
 457             goto finish;
 458     } else {
 459         sv_catpv(t, "FREED");
 460         goto finish;
 461     }
 462
 463     if (SvPOKp(sv)) {
 464         if (!SvPVX_const(sv))
 465             sv_catpv(t, "(null)");
 466         else {
 467             SV * const tmp = newSVpvs("");
 468             sv_catpv(t, "(");
 469             if (SvOOK(sv)) {
 470                 STRLEN delta;
 471                 SvOOK_offset(sv, delta);
 472                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
 473             }
 474             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
 475             if (SvUTF8(sv))
 476                 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
 477                                sv_uni_display(tmp, sv, 6 * SvCUR(sv),
 478                                               UNI_DISPLAY_QQ));
 479             SvREFCNT_dec_NN(tmp);
 480         }
 481     }
 482     else if (SvNOKp(sv)) {
 483         STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
 484         Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
 485         RESTORE_LC_NUMERIC_UNDERLYING();
 486     }
 487     else if (SvIOKp(sv)) {
 488         if (SvIsUV(sv))
 489             Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
 490         else
 491             Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
 492     }
 493     else
 494         sv_catpv(t, "()");
 495
 496   finish:
 497     while (unref--)
 498         sv_catpv(t, ")");
 499     if (TAINTING_get && sv && SvTAINTED(sv))
 500         sv_catpv(t, " [tainted]");
 501     return SvPV_nolen(t);
 502 }
 503
 504 /*
 505 =head1 Debugging Utilities
 506 */
 507
 508 void
 509 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
 510 {
 511     va_list args;
 512     PERL_ARGS_ASSERT_DUMP_INDENT;
 513     va_start(args, pat);
 514     dump_vindent(level, file, pat, &args);
 515     va_end(args);
 516 }
 517
 518 void
 519 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
 520 {
 521     PERL_ARGS_ASSERT_DUMP_VINDENT;
 522     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
 523     PerlIO_vprintf(file, pat, *args);
 524 }
 525
 526 /*
 527 =for apidoc dump_all
 528
 529 Dumps the entire optree of the current program starting at C<PL_main_root> to
 530 C<STDERR>.  Also dumps the optrees for all visible subroutines in
 531 C<PL_defstash>.
 532
 533 =cut
 534 */
 535
 536 void
 537 Perl_dump_all(pTHX)
 538 {
 539     dump_all_perl(FALSE);
 540 }
 541
 542 void
 543 Perl_dump_all_perl(pTHX_ bool justperl)
 544 {
 545     PerlIO_setlinebuf(Perl_debug_log);
 546     if (PL_main_root)
 547         op_dump(PL_main_root);
 548     dump_packsubs_perl(PL_defstash, justperl);
 549 }
 550
 551 /*
 552 =for apidoc dump_packsubs
 553
 554 Dumps the optrees for all visible subroutines in C<stash>.
 555
 556 =cut
 557 */
 558
 559 void
 560 Perl_dump_packsubs(pTHX_ const HV *stash)
 561 {
 562     PERL_ARGS_ASSERT_DUMP_PACKSUBS;
 563     dump_packsubs_perl(stash, FALSE);
 564 }
 565
 566 void
 567 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
 568 {
 569     I32 i;
 570
 571     PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
 572
 573     if (!HvARRAY(stash))
 574         return;
 575     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 576         const HE *entry;
 577         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 578             GV * gv = (GV *)HeVAL(entry);
 579             if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
 580                 /* unfake a fake GV */
 581                 (void)CvGV(SvRV(gv));
 582             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 583                 continue;
 584             if (GvCVu(gv))
 585                 dump_sub_perl(gv, justperl);
 586             if (GvFORM(gv))
 587                 dump_form(gv);
 588             if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
 589                 const HV * const hv = GvHV(gv);
 590                 if (hv && (hv != PL_defstash))
 591                     dump_packsubs_perl(hv, justperl); /* nested package */
 592             }
 593         }
 594     }
 595 }
 596
 597 void
 598 Perl_dump_sub(pTHX_ const GV *gv)
 599 {
 600     PERL_ARGS_ASSERT_DUMP_SUB;
 601     dump_sub_perl(gv, FALSE);
 602 }
 603
 604 void
 605 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
 606 {
 607     STRLEN len;
 608     SV * const sv = newSVpvs_flags("", SVs_TEMP);
 609     SV *tmpsv;
 610     const char * name;
 611
 612     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
 613
 614     if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
 615         return;
 616
 617     tmpsv = newSVpvs_flags("", SVs_TEMP);
 618     gv_fullname3(sv, gv, NULL);
 619     name = SvPV_const(sv, len);
 620     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
 621                      generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
 622     if (CvISXSUB(GvCV(gv)))
 623         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
 624             PTR2UV(CvXSUB(GvCV(gv))),
 625             (int)CvXSUBANY(GvCV(gv)).any_i32);
 626     else if (CvROOT(GvCV(gv)))
 627         op_dump(CvROOT(GvCV(gv)));
 628     else
 629         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 630 }
 631
 632 void
 633 Perl_dump_form(pTHX_ const GV *gv)
 634 {
 635     SV * const sv = sv_newmortal();
 636
 637     PERL_ARGS_ASSERT_DUMP_FORM;
 638
 639     gv_fullname3(sv, gv, NULL);
 640     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
 641     if (CvROOT(GvFORM(gv)))
 642         op_dump(CvROOT(GvFORM(gv)));
 643     else
 644         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 645 }
 646
 647 void
 648 Perl_dump_eval(pTHX)
 649 {
 650     op_dump(PL_eval_root);
 651 }
 652
 653 void
 654 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
 655 {
 656     char ch;
 657
 658     PERL_ARGS_ASSERT_DO_PMOP_DUMP;
 659
 660     if (!pm)
 661         return;
 662     if (pm->op_pmflags & PMf_ONCE)
 663         ch = '?';
 664     else
 665         ch = '/';
 666     if (PM_GETRE(pm))
 667         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n",
 668              ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch,
 669              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
 670     else
 671         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
 672
 673     if (pm->op_type == OP_SPLIT)
 674         Perl_dump_indent(aTHX_ level, file, "TARGOFF/GV = 0x%"UVxf"\n",
 675                 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
 676     else {
 677         if (pm->op_pmreplrootu.op_pmreplroot) {
 678             Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
 679             op_dump(pm->op_pmreplrootu.op_pmreplroot);
 680         }
 681     }
 682
 683     if (pm->op_code_list) {
 684         if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
 685             Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
 686             do_op_dump(level, file, pm->op_code_list);
 687         }
 688         else
 689             Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
 690                                     PTR2UV(pm->op_code_list));
 691     }
 692     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
 693         SV * const tmpsv = pm_description(pm);
 694         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 695         SvREFCNT_dec_NN(tmpsv);
 696     }
 697 }
 698
 699 const struct flag_to_name pmflags_flags_names[] = {
 700     {PMf_CONST, ",CONST"},
 701     {PMf_KEEP, ",KEEP"},
 702     {PMf_GLOBAL, ",GLOBAL"},
 703     {PMf_CONTINUE, ",CONTINUE"},
 704     {PMf_RETAINT, ",RETAINT"},
 705     {PMf_EVAL, ",EVAL"},
 706     {PMf_NONDESTRUCT, ",NONDESTRUCT"},
 707     {PMf_HAS_CV, ",HAS_CV"},
 708     {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
 709     {PMf_IS_QR, ",IS_QR"}
 710 };
 711
 712 static SV *
 713 S_pm_description(pTHX_ const PMOP *pm)
 714 {
 715     SV * const desc = newSVpvs("");
 716     const REGEXP * const regex = PM_GETRE(pm);
 717     const U32 pmflags = pm->op_pmflags;
 718
 719     PERL_ARGS_ASSERT_PM_DESCRIPTION;
 720
 721     if (pmflags & PMf_ONCE)
 722         sv_catpv(desc, ",ONCE");
 723 #ifdef USE_ITHREADS
 724     if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
 725         sv_catpv(desc, ":USED");
 726 #else
 727     if (pmflags & PMf_USED)
 728         sv_catpv(desc, ":USED");
 729 #endif
 730
 731     if (regex) {
 732         if (RX_ISTAINTED(regex))
 733             sv_catpv(desc, ",TAINTED");
 734         if (RX_CHECK_SUBSTR(regex)) {
 735             if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
 736                 sv_catpv(desc, ",SCANFIRST");
 737             if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
 738                 sv_catpv(desc, ",ALL");
 739         }
 740         if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
 741             sv_catpv(desc, ",SKIPWHITE");
 742     }
 743
 744     append_flags(desc, pmflags, pmflags_flags_names);
 745     return desc;
 746 }
 747
 748 void
 749 Perl_pmop_dump(pTHX_ PMOP *pm)
 750 {
 751     do_pmop_dump(0, Perl_debug_log, pm);
 752 }
 753
 754 /* Return a unique integer to represent the address of op o.
 755  * If it already exists in PL_op_sequence, just return it;
 756  * otherwise add it.
 757  *  *** Note that this isn't thread-safe */
 758
 759 STATIC UV
 760 S_sequence_num(pTHX_ const OP *o)
 761 {
 762     dVAR;
 763     SV     *op,
 764           **seq;
 765     const char *key;
 766     STRLEN  len;
 767     if (!o)
 768         return 0;
 769     op = newSVuv(PTR2UV(o));
 770     sv_2mortal(op);
 771     key = SvPV_const(op, len);
 772     if (!PL_op_sequence)
 773         PL_op_sequence = newHV();
 774     seq = hv_fetch(PL_op_sequence, key, len, 0);
 775     if (seq)
 776         return SvUV(*seq);
 777     (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
 778     return PL_op_seq;
 779 }
 780
 781
 782
 783
 784
 785 const struct flag_to_name op_flags_names[] = {
 786     {OPf_KIDS, ",KIDS"},
 787     {OPf_PARENS, ",PARENS"},
 788     {OPf_REF, ",REF"},
 789     {OPf_MOD, ",MOD"},
 790     {OPf_STACKED, ",STACKED"},
 791     {OPf_SPECIAL, ",SPECIAL"}
 792 };
 793
 794
 795 void
 796 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
 797 {
 798     UV      seq;
 799     const OPCODE optype = o->op_type;
 800
 801     PERL_ARGS_ASSERT_DO_OP_DUMP;
 802
 803     Perl_dump_indent(aTHX_ level, file, "{\n");
 804     level++;
 805     seq = sequence_num(o);
 806     if (seq)
 807         PerlIO_printf(file, "%-4"UVuf, seq);
 808     else
 809         PerlIO_printf(file, "????");
 810     PerlIO_printf(file,
 811                   "%*sTYPE = %s  ===> ",
 812                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
 813     if (o->op_next)
 814         PerlIO_printf(file,
 815                         o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
 816                                 sequence_num(o->op_next));
 817     else
 818         PerlIO_printf(file, "NULL\n");
 819     if (o->op_targ) {
 820         if (optype == OP_NULL) {
 821             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
 822         }
 823         else
 824             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
 825     }
 826 #ifdef DUMPADDR
 827     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
 828 #endif
 829
 830     if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
 831         SV * const tmpsv = newSVpvs("");
 832         switch (o->op_flags & OPf_WANT) {
 833         case OPf_WANT_VOID:
 834             sv_catpv(tmpsv, ",VOID");
 835             break;
 836         case OPf_WANT_SCALAR:
 837             sv_catpv(tmpsv, ",SCALAR");
 838             break;
 839         case OPf_WANT_LIST:
 840             sv_catpv(tmpsv, ",LIST");
 841             break;
 842         default:
 843             sv_catpv(tmpsv, ",UNKNOWN");
 844             break;
 845         }
 846         append_flags(tmpsv, o->op_flags, op_flags_names);
 847         if (o->op_slabbed)  sv_catpvs(tmpsv, ",SLABBED");
 848         if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
 849         if (o->op_static)   sv_catpvs(tmpsv, ",STATIC");
 850         if (o->op_folded)   sv_catpvs(tmpsv, ",FOLDED");
 851         if (o->op_moresib)  sv_catpvs(tmpsv, ",MORESIB");
 852         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
 853                          SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 854     }
 855
 856     if (o->op_private) {
 857         U16 oppriv = o->op_private;
 858         I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
 859         SV * tmpsv = NULL;
 860
 861         if (op_ix != -1) {
 862             U16 stop = 0;
 863             tmpsv = newSVpvs("");
 864             for (; !stop; op_ix++) {
 865                 U16 entry = PL_op_private_bitdefs[op_ix];
 866                 U16 bit = (entry >> 2) & 7;
 867                 U16 ix = entry >> 5;
 868
 869                 stop = (entry & 1);
 870
 871                 if (entry & 2) {
 872                     /* bitfield */
 873                     I16 const *p = &PL_op_private_bitfields[ix];
 874                     U16 bitmin = (U16) *p++;
 875                     I16 label = *p++;
 876                     I16 enum_label;
 877                     U16 mask = 0;
 878                     U16 i;
 879                     U16 val;
 880
 881                     for (i = bitmin; i<= bit; i++)
 882                         mask |= (1<<i);
 883                     bit = bitmin;
 884                     val = (oppriv & mask);
 885
 886                     if (   label != -1
 887                         && PL_op_private_labels[label] == '-'
 888                         && PL_op_private_labels[label+1] == '\0'
 889                     )
 890                         /* display as raw number */
 891                         continue;
 892
 893                     oppriv -= val;
 894                     val >>= bit;
 895                     enum_label = -1;
 896                     while (*p != -1) {
 897                         if (val == *p++) {
 898                             enum_label = *p;
 899                             break;
 900                         }
 901                         p++;
 902                     }
 903                     if (val == 0 && enum_label == -1)
 904                         /* don't display anonymous zero values */
 905                         continue;
 906
 907                     sv_catpv(tmpsv, ",");
 908                     if (label != -1) {
 909                         sv_catpv(tmpsv, &PL_op_private_labels[label]);
 910                         sv_catpv(tmpsv, "=");
 911                     }
 912                     if (enum_label == -1)
 913                         Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)val);
 914                     else
 915                         sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
 916
 917                 }
 918                 else {
 919                     /* bit flag */
 920                     if (   oppriv & (1<<bit)
 921                         && !(PL_op_private_labels[ix] == '-'
 922                              && PL_op_private_labels[ix+1] == '\0'))
 923                     {
 924                         oppriv -= (1<<bit);
 925                         sv_catpv(tmpsv, ",");
 926                         sv_catpv(tmpsv, &PL_op_private_labels[ix]);
 927                     }
 928                 }
 929             }
 930             if (oppriv) {
 931                 sv_catpv(tmpsv, ",");
 932                 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
 933             }
 934         }
 935         if (tmpsv && SvCUR(tmpsv)) {
 936             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
 937         } else
 938             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
 939                              (UV)oppriv);
 940     }
 941
 942     switch (optype) {
 943     case OP_AELEMFAST:
 944     case OP_GVSV:
 945     case OP_GV:
 946 #ifdef USE_ITHREADS
 947         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
 948 #else
 949         if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
 950             if (cSVOPo->op_sv) {
 951       STRLEN len;
 952       const char * name;
 953       SV * const tmpsv  = newSVpvs_flags("", SVs_TEMP);
 954       SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
 955                 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
 956       name = SvPV_const(tmpsv, len);
 957                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
 958                        generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
 959             }
 960             else
 961                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
 962         }
 963 #endif
 964         break;
 965
 966     case OP_MULTIDEREF:
 967     {
 968         UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
 969         UV i, count = items[-1].uv;
 970
 971         Perl_dump_indent(aTHX_ level, file, "ARGS = \n");
 972         for (i=0; i < count;  i++)
 973             Perl_dump_indent(aTHX_ level+1, file, "%"UVuf" => 0x%"UVxf"\n",
 974                                     i, items[i].uv);
 975         break;
 976     }
 977
 978     case OP_CONST:
 979     case OP_HINTSEVAL:
 980     case OP_METHOD_NAMED:
 981     case OP_METHOD_SUPER:
 982     case OP_METHOD_REDIR:
 983     case OP_METHOD_REDIR_SUPER:
 984 #ifndef USE_ITHREADS
 985         /* with ITHREADS, consts are stored in the pad, and the right pad
 986          * may not be active here, so skip */
 987         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
 988 #endif
 989         break;
 990     case OP_NULL:
 991         if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
 992             break;
 993         /* FALLTHROUGH */
 994     case OP_NEXTSTATE:
 995     case OP_DBSTATE:
 996         if (CopLINE(cCOPo))
 997             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
 998                              (UV)CopLINE(cCOPo));
 999     if (CopSTASHPV(cCOPo)) {
1000         SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1001         HV *stash = CopSTASH(cCOPo);
1002         const char * const hvname = HvNAME_get(stash);
1003
1004             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
1005                            generic_pv_escape(tmpsv, hvname,
1006                               HvNAMELEN(stash), HvNAMEUTF8(stash)));
1007     }
1008   if (CopLABEL(cCOPo)) {
1009        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1010        STRLEN label_len;
1011        U32 label_flags;
1012        const char *label = CopLABEL_len_flags(cCOPo,
1013                                                 &label_len, &label_flags);
1014        Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1015                            generic_pv_escape( tmpsv, label, label_len,
1016                                       (label_flags & SVf_UTF8)));
1017    }
1018         Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
1019                          (unsigned int)cCOPo->cop_seq);
1020         break;
1021     case OP_ENTERLOOP:
1022         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
1023         if (cLOOPo->op_redoop)
1024             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
1025         else
1026             PerlIO_printf(file, "DONE\n");
1027         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
1028         if (cLOOPo->op_nextop)
1029             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
1030         else
1031             PerlIO_printf(file, "DONE\n");
1032         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
1033         if (cLOOPo->op_lastop)
1034             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
1035         else
1036             PerlIO_printf(file, "DONE\n");
1037         break;
1038     case OP_COND_EXPR:
1039     case OP_RANGE:
1040     case OP_MAPWHILE:
1041     case OP_GREPWHILE:
1042     case OP_OR:
1043     case OP_AND:
1044         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
1045         if (cLOGOPo->op_other)
1046             PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
1047         else
1048             PerlIO_printf(file, "DONE\n");
1049         break;
1050     case OP_SPLIT:
1051     case OP_MATCH:
1052     case OP_QR:
1053     case OP_SUBST:
1054         do_pmop_dump(level, file, cPMOPo);
1055         break;
1056     case OP_LEAVE:
1057     case OP_LEAVEEVAL:
1058     case OP_LEAVESUB:
1059     case OP_LEAVESUBLV:
1060     case OP_LEAVEWRITE:
1061     case OP_SCOPE:
1062         if (o->op_private & OPpREFCOUNTED)
1063             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1064         break;
1065     default:
1066         break;
1067     }
1068     if (o->op_flags & OPf_KIDS) {
1069         OP *kid;
1070         for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
1071             do_op_dump(level, file, kid);
1072     }
1073     Perl_dump_indent(aTHX_ level-1, file, "}\n");
1074 }
1075
1076 /*
1077 =for apidoc op_dump
1078
1079 Dumps the optree starting at OP C<o> to C<STDERR>.
1080
1081 =cut
1082 */
1083
1084 void
1085 Perl_op_dump(pTHX_ const OP *o)
1086 {
1087     PERL_ARGS_ASSERT_OP_DUMP;
1088     do_op_dump(0, Perl_debug_log, o);
1089 }
1090
1091 void
1092 Perl_gv_dump(pTHX_ GV *gv)
1093 {
1094     STRLEN len;
1095     const char* name;
1096     SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1097
1098     if (!gv) {
1099         PerlIO_printf(Perl_debug_log, "{}\n");
1100         return;
1101     }
1102     sv = sv_newmortal();
1103     PerlIO_printf(Perl_debug_log, "{\n");
1104     gv_fullname3(sv, gv, NULL);
1105     name = SvPV_const(sv, len);
1106     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1107                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1108     if (gv != GvEGV(gv)) {
1109         gv_efullname3(sv, GvEGV(gv), NULL);
1110         name = SvPV_const(sv, len);
1111         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1112                      generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
1113     }
1114     (void)PerlIO_putc(Perl_debug_log, '\n');
1115     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
1116 }
1117
1118
1119 /* map magic types to the symbolic names
1120  * (with the PERL_MAGIC_ prefixed stripped)
1121  */
1122
1123 static const struct { const char type; const char *name; } magic_names[] = {
1124 #include "mg_names.inc"
1125         /* this null string terminates the list */
1126         { 0,                         NULL },
1127 };
1128
1129 void
1130 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1131 {
1132     PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1133
1134     for (; mg; mg = mg->mg_moremagic) {
1135         Perl_dump_indent(aTHX_ level, file,
1136                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1137         if (mg->mg_virtual) {
1138             const MGVTBL * const v = mg->mg_virtual;
1139             if (v >= PL_magic_vtables
1140                 && v < PL_magic_vtables + magic_vtable_max) {
1141                 const U32 i = v - PL_magic_vtables;
1142                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1143             }
1144             else
1145                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1146         }
1147         else
1148             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1149
1150         if (mg->mg_private)
1151             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1152
1153         {
1154             int n;
1155             const char *name = NULL;
1156             for (n = 0; magic_names[n].name; n++) {
1157                 if (mg->mg_type == magic_names[n].type) {
1158                     name = magic_names[n].name;
1159                     break;
1160                 }
1161             }
1162             if (name)
1163                 Perl_dump_indent(aTHX_ level, file,
1164                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1165             else
1166                 Perl_dump_indent(aTHX_ level, file,
1167                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1168         }
1169
1170         if (mg->mg_flags) {
1171             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1172             if (mg->mg_type == PERL_MAGIC_envelem &&
1173                 mg->mg_flags & MGf_TAINTEDDIR)
1174                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1175             if (mg->mg_type == PERL_MAGIC_regex_global &&
1176                 mg->mg_flags & MGf_MINMATCH)
1177                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1178             if (mg->mg_flags & MGf_REFCOUNTED)
1179                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1180             if (mg->mg_flags & MGf_GSKIP)
1181                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1182             if (mg->mg_flags & MGf_COPY)
1183                 Perl_dump_indent(aTHX_ level, file, "      COPY\n");
1184             if (mg->mg_flags & MGf_DUP)
1185                 Perl_dump_indent(aTHX_ level, file, "      DUP\n");
1186             if (mg->mg_flags & MGf_LOCAL)
1187                 Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
1188             if (mg->mg_type == PERL_MAGIC_regex_global &&
1189                 mg->mg_flags & MGf_BYTES)
1190                 Perl_dump_indent(aTHX_ level, file, "      BYTES\n");
1191         }
1192         if (mg->mg_obj) {
1193             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",
1194                 PTR2UV(mg->mg_obj));
1195             if (mg->mg_type == PERL_MAGIC_qr) {
1196                 REGEXP* const re = (REGEXP *)mg->mg_obj;
1197                 SV * const dsv = sv_newmortal();
1198                 const char * const s
1199                     = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
1200                     60, NULL, NULL,
1201                     ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
1202                     (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
1203                 );
1204                 Perl_dump_indent(aTHX_ level+1, file, "    PAT = %s\n", s);
1205                 Perl_dump_indent(aTHX_ level+1, file, "    REFCNT = %"IVdf"\n",
1206                         (IV)RX_REFCNT(re));
1207             }
1208             if (mg->mg_flags & MGf_REFCOUNTED)
1209                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1210         }
1211         if (mg->mg_len)
1212             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1213         if (mg->mg_ptr) {
1214             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1215             if (mg->mg_len >= 0) {
1216                 if (mg->mg_type != PERL_MAGIC_utf8) {
1217                     SV * const sv = newSVpvs("");
1218                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1219                     SvREFCNT_dec_NN(sv);
1220                 }
1221             }
1222             else if (mg->mg_len == HEf_SVKEY) {
1223                 PerlIO_puts(file, " => HEf_SVKEY\n");
1224                 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1225                            maxnest, dumpops, pvlim); /* MG is already +1 */
1226                 continue;
1227             }
1228             else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
1229             else
1230                 PerlIO_puts(
1231                   file,
1232                  " ???? - " __FILE__
1233                  " does not know how to handle this MG_LEN"
1234                 );
1235             (void)PerlIO_putc(file, '\n');
1236         }
1237         if (mg->mg_type == PERL_MAGIC_utf8) {
1238             const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
1239             if (cache) {
1240                 IV i;
1241                 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1242                     Perl_dump_indent(aTHX_ level, file,
1243                                      "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1244                                      i,
1245                                      (UV)cache[i * 2],
1246                                      (UV)cache[i * 2 + 1]);
1247             }
1248         }
1249     }
1250 }
1251
1252 void
1253 Perl_magic_dump(pTHX_ const MAGIC *mg)
1254 {
1255     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1256 }
1257
1258 void
1259 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
1260 {
1261     const char *hvname;
1262
1263     PERL_ARGS_ASSERT_DO_HV_DUMP;
1264
1265     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1266     if (sv && (hvname = HvNAME_get(sv)))
1267     {
1268         /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1269            name which quite legally could contain insane things like tabs, newlines, nulls or
1270            other scary crap - this should produce sane results - except maybe for unicode package
1271            names - but we will wait for someone to file a bug on that - demerphq */
1272         SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1273         PerlIO_printf(file, "\t\"%s\"\n",
1274                               generic_pv_escape( tmpsv, hvname,
1275                                    HvNAMELEN(sv), HvNAMEUTF8(sv)));
1276     }
1277     else
1278         (void)PerlIO_putc(file, '\n');
1279 }
1280
1281 void
1282 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1283 {
1284     PERL_ARGS_ASSERT_DO_GV_DUMP;
1285
1286     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1287     if (sv && GvNAME(sv)) {
1288         SV * const tmpsv = newSVpvs("");
1289         PerlIO_printf(file, "\t\"%s\"\n",
1290                               generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1291     }
1292     else
1293         (void)PerlIO_putc(file, '\n');
1294 }
1295
1296 void
1297 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
1298 {
1299     PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1300
1301     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1302     if (sv && GvNAME(sv)) {
1303        SV *tmp = newSVpvs_flags("", SVs_TEMP);
1304         const char *hvname;
1305         HV * const stash = GvSTASH(sv);
1306         PerlIO_printf(file, "\t");
1307    /* TODO might have an extra \" here */
1308         if (stash && (hvname = HvNAME_get(stash))) {
1309             PerlIO_printf(file, "\"%s\" :: \"",
1310                                   generic_pv_escape(tmp, hvname,
1311                                       HvNAMELEN(stash), HvNAMEUTF8(stash)));
1312         }
1313         PerlIO_printf(file, "%s\"\n",
1314                               generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
1315     }
1316     else
1317         (void)PerlIO_putc(file, '\n');
1318 }
1319
1320 const struct flag_to_name first_sv_flags_names[] = {
1321     {SVs_TEMP, "TEMP,"},
1322     {SVs_OBJECT, "OBJECT,"},
1323     {SVs_GMG, "GMG,"},
1324     {SVs_SMG, "SMG,"},
1325     {SVs_RMG, "RMG,"},
1326     {SVf_IOK, "IOK,"},
1327     {SVf_NOK, "NOK,"},
1328     {SVf_POK, "POK,"}
1329 };
1330
1331 const struct flag_to_name second_sv_flags_names[] = {
1332     {SVf_OOK, "OOK,"},
1333     {SVf_FAKE, "FAKE,"},
1334     {SVf_READONLY, "READONLY,"},
1335     {SVf_PROTECT, "PROTECT,"},
1336     {SVf_BREAK, "BREAK,"},
1337     {SVp_IOK, "pIOK,"},
1338     {SVp_NOK, "pNOK,"},
1339     {SVp_POK, "pPOK,"}
1340 };
1341
1342 const struct flag_to_name cv_flags_names[] = {
1343     {CVf_ANON, "ANON,"},
1344     {CVf_UNIQUE, "UNIQUE,"},
1345     {CVf_CLONE, "CLONE,"},
1346     {CVf_CLONED, "CLONED,"},
1347     {CVf_CONST, "CONST,"},
1348     {CVf_NODEBUG, "NODEBUG,"},
1349     {CVf_LVALUE, "LVALUE,"},
1350     {CVf_METHOD, "METHOD,"},
1351     {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
1352     {CVf_CVGV_RC, "CVGV_RC,"},
1353     {CVf_DYNFILE, "DYNFILE,"},
1354     {CVf_AUTOLOAD, "AUTOLOAD,"},
1355     {CVf_HASEVAL, "HASEVAL,"},
1356     {CVf_SLABBED, "SLABBED,"},
1357     {CVf_NAMED, "NAMED,"},
1358     {CVf_LEXICAL, "LEXICAL,"},
1359     {CVf_ISXSUB, "ISXSUB,"}
1360 };
1361
1362 const struct flag_to_name hv_flags_names[] = {
1363     {SVphv_SHAREKEYS, "SHAREKEYS,"},
1364     {SVphv_LAZYDEL, "LAZYDEL,"},
1365     {SVphv_HASKFLAGS, "HASKFLAGS,"},
1366     {SVf_AMAGIC, "OVERLOAD,"},
1367     {SVphv_CLONEABLE, "CLONEABLE,"}
1368 };
1369
1370 const struct flag_to_name gp_flags_names[] = {
1371     {GVf_INTRO, "INTRO,"},
1372     {GVf_MULTI, "MULTI,"},
1373     {GVf_ASSUMECV, "ASSUMECV,"},
1374 };
1375
1376 const struct flag_to_name gp_flags_imported_names[] = {
1377     {GVf_IMPORTED_SV, " SV"},
1378     {GVf_IMPORTED_AV, " AV"},
1379     {GVf_IMPORTED_HV, " HV"},
1380     {GVf_IMPORTED_CV, " CV"},
1381 };
1382
1383 /* NOTE: this structure is mostly duplicative of one generated by
1384  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1385  * the two. - Yves */
1386 const struct flag_to_name regexp_extflags_names[] = {
1387     {RXf_PMf_MULTILINE,   "PMf_MULTILINE,"},
1388     {RXf_PMf_SINGLELINE,  "PMf_SINGLELINE,"},
1389     {RXf_PMf_FOLD,        "PMf_FOLD,"},
1390     {RXf_PMf_EXTENDED,    "PMf_EXTENDED,"},
1391     {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
1392     {RXf_PMf_KEEPCOPY,    "PMf_KEEPCOPY,"},
1393     {RXf_PMf_NOCAPTURE,   "PMf_NOCAPURE,"},
1394     {RXf_IS_ANCHORED,     "IS_ANCHORED,"},
1395     {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
1396     {RXf_EVAL_SEEN,       "EVAL_SEEN,"},
1397     {RXf_CHECK_ALL,       "CHECK_ALL,"},
1398     {RXf_MATCH_UTF8,      "MATCH_UTF8,"},
1399     {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1400     {RXf_USE_INTUIT_ML,   "USE_INTUIT_ML,"},
1401     {RXf_INTUIT_TAIL,     "INTUIT_TAIL,"},
1402     {RXf_SPLIT,           "SPLIT,"},
1403     {RXf_COPY_DONE,       "COPY_DONE,"},
1404     {RXf_TAINTED_SEEN,    "TAINTED_SEEN,"},
1405     {RXf_TAINTED,         "TAINTED,"},
1406     {RXf_START_ONLY,      "START_ONLY,"},
1407     {RXf_SKIPWHITE,       "SKIPWHITE,"},
1408     {RXf_WHITE,           "WHITE,"},
1409     {RXf_NULL,            "NULL,"},
1410 };
1411
1412 /* NOTE: this structure is mostly duplicative of one generated by
1413  * 'make regen' in regnodes.h - perhaps we should somehow integrate
1414  * the two. - Yves */
1415 const struct flag_to_name regexp_core_intflags_names[] = {
1416     {PREGf_SKIP,            "SKIP,"},
1417     {PREGf_IMPLICIT,        "IMPLICIT,"},
1418     {PREGf_NAUGHTY,         "NAUGHTY,"},
1419     {PREGf_VERBARG_SEEN,    "VERBARG_SEEN,"},
1420     {PREGf_CUTGROUP_SEEN,   "CUTGROUP_SEEN,"},
1421     {PREGf_USE_RE_EVAL,     "USE_RE_EVAL,"},
1422     {PREGf_NOSCAN,          "NOSCAN,"},
1423     {PREGf_GPOS_SEEN,       "GPOS_SEEN,"},
1424     {PREGf_GPOS_FLOAT,      "GPOS_FLOAT,"},
1425     {PREGf_ANCH_MBOL,       "ANCH_MBOL,"},
1426     {PREGf_ANCH_SBOL,       "ANCH_SBOL,"},
1427     {PREGf_ANCH_GPOS,       "ANCH_GPOS,"},
1428 };
1429
1430 /* Perl_do_sv_dump():
1431  *
1432  * level:   amount to indent the output
1433  * sv:      the object to dump
1434  * nest:    the current level of recursion
1435  * maxnest: the maximum allowed level of recursion
1436  * dumpops: if true, also dump the ops associated with a CV
1437  * pvlim:   limit on the length of any strings that are output
1438  * */
1439
1440 void
1441 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1442 {
1443     SV *d;
1444     const char *s;
1445     U32 flags;
1446     U32 type;
1447
1448     PERL_ARGS_ASSERT_DO_SV_DUMP;
1449
1450     if (!sv) {
1451         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1452         return;
1453     }
1454
1455     flags = SvFLAGS(sv);
1456     type = SvTYPE(sv);
1457
1458     /* process general SV flags */
1459
1460     d = Perl_newSVpvf(aTHX_
1461                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1462                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1463                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1464                    (int)(PL_dumpindent*level), "");
1465
1466     if ((flags & SVs_PADSTALE))
1467             sv_catpv(d, "PADSTALE,");
1468     if ((flags & SVs_PADTMP))
1469             sv_catpv(d, "PADTMP,");
1470     append_flags(d, flags, first_sv_flags_names);
1471     if (flags & SVf_ROK)  {
1472                                 sv_catpv(d, "ROK,");
1473         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1474     }
1475     if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
1476     append_flags(d, flags, second_sv_flags_names);
1477     if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1478                            && type != SVt_PVAV) {
1479         if (SvPCS_IMPORTED(sv))
1480                                 sv_catpv(d, "PCS_IMPORTED,");
1481         else
1482                                 sv_catpv(d, "SCREAM,");
1483     }
1484
1485     /* process type-specific SV flags */
1486
1487     switch (type) {
1488     case SVt_PVCV:
1489     case SVt_PVFM:
1490         append_flags(d, CvFLAGS(sv), cv_flags_names);
1491         break;
1492     case SVt_PVHV:
1493         append_flags(d, flags, hv_flags_names);
1494         break;
1495     case SVt_PVGV:
1496     case SVt_PVLV:
1497         if (isGV_with_GP(sv)) {
1498             append_flags(d, GvFLAGS(sv), gp_flags_names);
1499         }
1500         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1501             sv_catpv(d, "IMPORT");
1502             if (GvIMPORTED(sv) == GVf_IMPORTED)
1503                 sv_catpv(d, "ALL,");
1504             else {
1505                 sv_catpv(d, "(");
1506                 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
1507                 sv_catpv(d, " ),");
1508             }
1509         }
1510         /* FALLTHROUGH */
1511     default:
1512     do_uv:
1513         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1514         break;
1515     case SVt_PVMG:
1516         if (SvVALID(sv)) {
1517             sv_catpv(d, "VALID,");
1518             if (SvTAIL(sv))
1519                 sv_catpv(d, "TAIL,");
1520             }
1521         goto do_uv;
1522     case SVt_PVAV:
1523         break;
1524     }
1525     /* SVphv_SHAREKEYS is also 0x20000000 */
1526     if ((type != SVt_PVHV) && SvUTF8(sv))
1527         sv_catpv(d, "UTF8");
1528
1529     if (*(SvEND(d) - 1) == ',') {
1530         SvCUR_set(d, SvCUR(d) - 1);
1531         SvPVX(d)[SvCUR(d)] = '\0';
1532     }
1533     sv_catpv(d, ")");
1534     s = SvPVX_const(d);
1535
1536     /* dump initial SV details */
1537
1538 #ifdef DEBUG_LEAKING_SCALARS
1539     Perl_dump_indent(aTHX_ level, file,
1540         "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
1541         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1542         sv->sv_debug_line,
1543         sv->sv_debug_inpad ? "for" : "by",
1544         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1545         PTR2UV(sv->sv_debug_parent),
1546         sv->sv_debug_serial
1547     );
1548 #endif
1549     Perl_dump_indent(aTHX_ level, file, "SV = ");
1550
1551     /* Dump SV type */
1552
1553     if (type < SVt_LAST) {
1554         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1555
1556         if (type ==  SVt_NULL) {
1557             SvREFCNT_dec_NN(d);
1558             return;
1559         }
1560     } else {
1561         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1562         SvREFCNT_dec_NN(d);
1563         return;
1564     }
1565
1566     /* Dump general SV fields */
1567
1568     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1569          && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1570          && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
1571         || (type == SVt_IV && !SvROK(sv))) {
1572         if (SvIsUV(sv)
1573                                      )
1574             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1575         else
1576             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1577         (void)PerlIO_putc(file, '\n');
1578     }
1579
1580     if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1581                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1582                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1583                || type == SVt_NV) {
1584         STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1585         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
1586         RESTORE_LC_NUMERIC_UNDERLYING();
1587     }
1588
1589     if (SvROK(sv)) {
1590         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1591         if (nest < maxnest)
1592             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1593     }
1594
1595     if (type < SVt_PV) {
1596         SvREFCNT_dec_NN(d);
1597         return;
1598     }
1599
1600     if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1601      || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
1602         const bool re = isREGEXP(sv);
1603         const char * const ptr =
1604             re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1605         if (ptr) {
1606             STRLEN delta;
1607             if (SvOOK(sv)) {
1608                 SvOOK_offset(sv, delta);
1609                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1610                                  (UV) delta);
1611             } else {
1612                 delta = 0;
1613             }
1614             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(ptr));
1615             if (SvOOK(sv)) {
1616                 PerlIO_printf(file, "( %s . ) ",
1617                               pv_display(d, ptr - delta, delta, 0,
1618                                          pvlim));
1619             }
1620             if (type == SVt_INVLIST) {
1621                 PerlIO_printf(file, "\n");
1622                 /* 4 blanks indents 2 beyond the PV, etc */
1623                 _invlist_dump(file, level, "    ", sv);
1624             }
1625             else {
1626                 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1627                                                      re ? 0 : SvLEN(sv),
1628                                                      pvlim));
1629                 if (SvUTF8(sv)) /* the 6?  \x{....} */
1630                     PerlIO_printf(file, " [UTF8 \"%s\"]",
1631                                          sv_uni_display(d, sv, 6 * SvCUR(sv),
1632                                                         UNI_DISPLAY_QQ));
1633                 PerlIO_printf(file, "\n");
1634             }
1635             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1636             if (!re)
1637                 Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n",
1638                                        (IV)SvLEN(sv));
1639 #ifdef PERL_COPY_ON_WRITE
1640             if (SvIsCOW(sv) && SvLEN(sv))
1641                 Perl_dump_indent(aTHX_ level, file, "  COW_REFCNT = %d\n",
1642                                        CowREFCNT(sv));
1643 #endif
1644         }
1645         else
1646             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1647     }
1648
1649     if (type >= SVt_PVMG) {
1650         if (SvMAGIC(sv))
1651                 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
1652         if (SvSTASH(sv))
1653             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1654
1655         if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1656             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1657         }
1658     }
1659
1660     /* Dump type-specific SV fields */
1661
1662     switch (type) {
1663     case SVt_PVAV:
1664         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1665         if (AvARRAY(sv) != AvALLOC(sv)) {
1666             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1667             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1668         }
1669         else
1670             (void)PerlIO_putc(file, '\n');
1671         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1672         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1673         SvPVCLEAR(d);
1674         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1675         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1676         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1677                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1678         if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
1679             SSize_t count;
1680             SV **svp = AvARRAY(MUTABLE_AV(sv));
1681             for (count = 0;
1682                  count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1683                  count++, svp++)
1684             {
1685                 SV* const elt = *svp;
1686                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1687                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1688             }
1689         }
1690         break;
1691     case SVt_PVHV: {
1692         U32 usedkeys;
1693         if (SvOOK(sv)) {
1694             struct xpvhv_aux *const aux = HvAUX(sv);
1695             Perl_dump_indent(aTHX_ level, file, "  AUX_FLAGS = %"UVuf"\n",
1696                              (UV)aux->xhv_aux_flags);
1697         }
1698         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1699         usedkeys = HvUSEDKEYS(sv);
1700         if (HvARRAY(sv) && usedkeys) {
1701             /* Show distribution of HEs in the ARRAY */
1702             int freq[200];
1703 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
1704             int i;
1705             int max = 0;
1706             U32 pow2 = 2, keys = usedkeys;
1707             NV theoret, sum = 0;
1708
1709             PerlIO_printf(file, "  (");
1710             Zero(freq, FREQ_MAX + 1, int);
1711             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1712                 HE* h;
1713                 int count = 0;
1714                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1715                     count++;
1716                 if (count > FREQ_MAX)
1717                     count = FREQ_MAX;
1718                 freq[count]++;
1719                 if (max < count)
1720                     max = count;
1721             }
1722             for (i = 0; i <= max; i++) {
1723                 if (freq[i]) {
1724                     PerlIO_printf(file, "%d%s:%d", i,
1725                                   (i == FREQ_MAX) ? "+" : "",
1726                                   freq[i]);
1727                     if (i != max)
1728                         PerlIO_printf(file, ", ");
1729                 }
1730             }
1731             (void)PerlIO_putc(file, ')');
1732             /* The "quality" of a hash is defined as the total number of
1733                comparisons needed to access every element once, relative
1734                to the expected number needed for a random hash.
1735
1736                The total number of comparisons is equal to the sum of
1737                the squares of the number of entries in each bucket.
1738                For a random hash of n keys into k buckets, the expected
1739                value is
1740                                 n + n(n-1)/2k
1741             */
1742
1743             for (i = max; i > 0; i--) { /* Precision: count down. */
1744                 sum += freq[i] * i * i;
1745             }
1746             while ((keys = keys >> 1))
1747                 pow2 = pow2 << 1;
1748             theoret = usedkeys;
1749             theoret += theoret * (theoret-1)/pow2;
1750             (void)PerlIO_putc(file, '\n');
1751             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1752         }
1753         (void)PerlIO_putc(file, '\n');
1754         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)usedkeys);
1755         {
1756             STRLEN count = 0;
1757             HE **ents = HvARRAY(sv);
1758
1759             if (ents) {
1760                 HE *const *const last = ents + HvMAX(sv);
1761                 count = last + 1 - ents;
1762
1763                 do {
1764                     if (!*ents)
1765                         --count;
1766                 } while (++ents <= last);
1767             }
1768
1769             Perl_dump_indent(aTHX_ level, file, "  FILL = %"UVuf"\n",
1770                              (UV)count);
1771         }
1772         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1773         if (SvOOK(sv)) {
1774             Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1775             Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1776 #ifdef PERL_HASH_RANDOMIZE_KEYS
1777             Perl_dump_indent(aTHX_ level, file, "  RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1778             if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
1779                 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
1780             }
1781 #endif
1782             (void)PerlIO_putc(file, '\n');
1783         }
1784         {
1785             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1786             if (mg && mg->mg_obj) {
1787                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1788             }
1789         }
1790         {
1791             const char * const hvname = HvNAME_get(sv);
1792             if (hvname) {
1793           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1794      Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1795                                        generic_pv_escape( tmpsv, hvname,
1796                                            HvNAMELEN(sv), HvNAMEUTF8(sv)));
1797         }
1798         }
1799         if (SvOOK(sv)) {
1800             AV * const backrefs
1801                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1802             struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
1803             if (HvAUX(sv)->xhv_name_count)
1804                 Perl_dump_indent(aTHX_
1805                  level, file, "  NAMECOUNT = %"IVdf"\n",
1806                  (IV)HvAUX(sv)->xhv_name_count
1807                 );
1808             if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
1809                 const I32 count = HvAUX(sv)->xhv_name_count;
1810                 if (count) {
1811                     SV * const names = newSVpvs_flags("", SVs_TEMP);
1812                     /* The starting point is the first element if count is
1813                        positive and the second element if count is negative. */
1814                     HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1815                         + (count < 0 ? 1 : 0);
1816                     HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1817                         + (count < 0 ? -count : count);
1818                     while (hekp < endp) {
1819                         if (*hekp) {
1820              SV *tmp = newSVpvs_flags("", SVs_TEMP);
1821                             Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1822                               generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
1823                         } else {
1824                             /* This should never happen. */
1825                             sv_catpvs(names, ", (null)");
1826                         }
1827                         ++hekp;
1828                     }
1829                     Perl_dump_indent(aTHX_
1830                      level, file, "  ENAME = %s\n", SvPV_nolen(names)+2
1831                     );
1832                 }
1833                 else {
1834                     SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1835                     const char *const hvename = HvENAME_get(sv);
1836                     Perl_dump_indent(aTHX_
1837                      level, file, "  ENAME = \"%s\"\n",
1838                      generic_pv_escape(tmp, hvename,
1839                                        HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1840                 }
1841             }
1842             if (backrefs) {
1843                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1844                                  PTR2UV(backrefs));
1845                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1846                            dumpops, pvlim);
1847             }
1848             if (meta) {
1849                 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1850                 Perl_dump_indent(aTHX_ level, file, "  MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1851                                  generic_pv_escape( tmpsv, meta->mro_which->name,
1852                                 meta->mro_which->length,
1853                                 (meta->mro_which->kflags & HVhek_UTF8)),
1854                                  PTR2UV(meta->mro_which));
1855                 Perl_dump_indent(aTHX_ level, file, "  CACHE_GEN = 0x%"UVxf"\n",
1856                                  (UV)meta->cache_gen);
1857                 Perl_dump_indent(aTHX_ level, file, "  PKG_GEN = 0x%"UVxf"\n",
1858                                  (UV)meta->pkg_gen);
1859                 if (meta->mro_linear_all) {
1860                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_ALL = 0x%"UVxf"\n",
1861                                  PTR2UV(meta->mro_linear_all));
1862                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1863                            dumpops, pvlim);
1864                 }
1865                 if (meta->mro_linear_current) {
1866                     Perl_dump_indent(aTHX_ level, file, "  MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1867                                  PTR2UV(meta->mro_linear_current));
1868                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1869                            dumpops, pvlim);
1870                 }
1871                 if (meta->mro_nextmethod) {
1872                     Perl_dump_indent(aTHX_ level, file, "  MRO_NEXTMETHOD = 0x%"UVxf"\n",
1873                                  PTR2UV(meta->mro_nextmethod));
1874                 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1875                            dumpops, pvlim);
1876                 }
1877                 if (meta->isa) {
1878                     Perl_dump_indent(aTHX_ level, file, "  ISA = 0x%"UVxf"\n",
1879                                  PTR2UV(meta->isa));
1880                 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1881                            dumpops, pvlim);
1882                 }
1883             }
1884         }
1885         if (nest < maxnest) {
1886             HV * const hv = MUTABLE_HV(sv);
1887             STRLEN i;
1888             HE *he;
1889
1890             if (HvARRAY(hv)) {
1891                 int count = maxnest - nest;
1892                 for (i=0; i <= HvMAX(hv); i++) {
1893                     for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1894                         U32 hash;
1895                         SV * keysv;
1896                         const char * keypv;
1897                         SV * elt;
1898                         STRLEN len;
1899
1900                         if (count-- <= 0) goto DONEHV;
1901
1902                         hash = HeHASH(he);
1903                         keysv = hv_iterkeysv(he);
1904                         keypv = SvPV_const(keysv, len);
1905                         elt = HeVAL(he);
1906
1907                         Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1908                         if (SvUTF8(keysv))
1909                             PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1910                         if (HvEITER_get(hv) == he)
1911                             PerlIO_printf(file, "[CURRENT] ");
1912                         PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1913                         do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1914                     }
1915                 }
1916               DONEHV:;
1917             }
1918         }
1919         break;
1920     } /* case SVt_PVHV */
1921
1922     case SVt_PVCV:
1923         if (CvAUTOLOAD(sv)) {
1924             SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1925        STRLEN len;
1926             const char *const name =  SvPV_const(sv, len);
1927             Perl_dump_indent(aTHX_ level, file, "  AUTOLOAD = \"%s\"\n",
1928                              generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
1929         }
1930         if (SvPOK(sv)) {
1931        SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1932        const char *const proto = CvPROTO(sv);
1933             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n",
1934                              generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1935                                 SvUTF8(sv)));
1936         }
1937         /* FALLTHROUGH */
1938     case SVt_PVFM:
1939         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1940         if (!CvISXSUB(sv)) {
1941             if (CvSTART(sv)) {
1942                 if (CvSLABBED(sv))
1943                     Perl_dump_indent(aTHX_ level, file,
1944                                  "  SLAB = 0x%"UVxf"\n",
1945                                  PTR2UV(CvSTART(sv)));
1946                 else
1947                     Perl_dump_indent(aTHX_ level, file,
1948                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1949                                  PTR2UV(CvSTART(sv)),
1950                                  (IV)sequence_num(CvSTART(sv)));
1951             }
1952             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1953                              PTR2UV(CvROOT(sv)));
1954             if (CvROOT(sv) && dumpops) {
1955                 do_op_dump(level+1, file, CvROOT(sv));
1956             }
1957         } else {
1958             SV * const constant = cv_const_sv((const CV *)sv);
1959
1960             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1961
1962             if (constant) {
1963                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1964                                  " (CONST SV)\n",
1965                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1966                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1967                            pvlim);
1968             } else {
1969                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1970                                  (IV)CvXSUBANY(sv).any_i32);
1971             }
1972         }
1973         if (CvNAMED(sv))
1974             Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
1975                                    HEK_KEY(CvNAME_HEK((CV *)sv)));
1976         else do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1977         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1978         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1979         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1980         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1981         if (!CvISXSUB(sv)) {
1982             Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1983             if (nest < maxnest) {
1984                 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1985             }
1986         }
1987         else
1988             Perl_dump_indent(aTHX_ level, file, "  HSCXT = 0x%p\n", CvHSCXT(sv));
1989         {
1990             const CV * const outside = CvOUTSIDE(sv);
1991             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1992                         PTR2UV(outside),
1993                         (!outside ? "null"
1994                          : CvANON(outside) ? "ANON"
1995                          : (outside == PL_main_cv) ? "MAIN"
1996                          : CvUNIQUE(outside) ? "UNIQUE"
1997                          : CvGV(outside) ?
1998                              generic_pv_escape(
1999                                  newSVpvs_flags("", SVs_TEMP),
2000                                  GvNAME(CvGV(outside)),
2001                                  GvNAMELEN(CvGV(outside)),
2002                                  GvNAMEUTF8(CvGV(outside)))
2003                          : "UNDEFINED"));
2004         }
2005         if (CvOUTSIDE(sv)
2006          && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
2007             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
2008         break;
2009
2010     case SVt_PVGV:
2011     case SVt_PVLV:
2012         if (type == SVt_PVLV) {
2013             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
2014             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2015             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2016             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
2017             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
2018             if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
2019                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2020                     dumpops, pvlim);
2021         }
2022         if (isREGEXP(sv)) goto dumpregexp;
2023         if (!isGV_with_GP(sv))
2024             break;
2025        {
2026           SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2027           Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n",
2028                     generic_pv_escape(tmpsv, GvNAME(sv),
2029                                       GvNAMELEN(sv),
2030                                       GvNAMEUTF8(sv)));
2031        }
2032         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
2033         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
2034         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
2035         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
2036         if (!GvGP(sv))
2037             break;
2038         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2039         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2040         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2041         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
2042         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2043         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2044         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2045         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
2046         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%"UVxf
2047                                             " (%s)\n",
2048                                (UV)GvGPFLAGS(sv),
2049                                "");
2050         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
2051         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
2052         do_gv_dump (level, file, "    EGV", GvEGV(sv));
2053         break;
2054     case SVt_PVIO:
2055         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2056         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2057         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2058         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
2059         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2060         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2061         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
2062         if (IoTOP_NAME(sv))
2063             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
2064         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2065             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
2066         else {
2067             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
2068                              PTR2UV(IoTOP_GV(sv)));
2069             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2070                         maxnest, dumpops, pvlim);
2071         }
2072         /* Source filters hide things that are not GVs in these three, so let's
2073            be careful out there.  */
2074         if (IoFMT_NAME(sv))
2075             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
2076         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2077             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
2078         else {
2079             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
2080                              PTR2UV(IoFMT_GV(sv)));
2081             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2082                         maxnest, dumpops, pvlim);
2083         }
2084         if (IoBOTTOM_NAME(sv))
2085             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
2086         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2087             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
2088         else {
2089             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
2090                              PTR2UV(IoBOTTOM_GV(sv)));
2091             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2092                         maxnest, dumpops, pvlim);
2093         }
2094         if (isPRINT(IoTYPE(sv)))
2095             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
2096         else
2097             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
2098         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
2099         break;
2100     case SVt_REGEXP:
2101       dumpregexp:
2102         {
2103             struct regexp * const r = ReANY((REGEXP*)sv);
2104
2105 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
2106             sv_setpv(d,"");                                 \
2107             append_flags(d, flags, names);     \
2108             if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') {       \
2109                 SvCUR_set(d, SvCUR(d) - 1);                 \
2110                 SvPVX(d)[SvCUR(d)] = '\0';                  \
2111             }                                               \
2112 } STMT_END
2113             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
2114             Perl_dump_indent(aTHX_ level, file, "  COMPFLAGS = 0x%"UVxf" (%s)\n",
2115                                 (UV)(r->compflags), SvPVX_const(d));
2116
2117             SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
2118             Perl_dump_indent(aTHX_ level, file, "  EXTFLAGS = 0x%"UVxf" (%s)\n",
2119                                 (UV)(r->extflags), SvPVX_const(d));
2120
2121             Perl_dump_indent(aTHX_ level, file, "  ENGINE = 0x%"UVxf" (%s)\n",
2122                                 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2123             if (r->engine == &PL_core_reg_engine) {
2124                 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2125                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf" (%s)\n",
2126                                 (UV)(r->intflags), SvPVX_const(d));
2127             } else {
2128                 Perl_dump_indent(aTHX_ level, file, "  INTFLAGS = 0x%"UVxf"\n",
2129                                 (UV)(r->intflags));
2130             }
2131 #undef SV_SET_STRINGIFY_REGEXP_FLAGS
2132             Perl_dump_indent(aTHX_ level, file, "  NPARENS = %"UVuf"\n",
2133                                 (UV)(r->nparens));
2134             Perl_dump_indent(aTHX_ level, file, "  LASTPAREN = %"UVuf"\n",
2135                                 (UV)(r->lastparen));
2136             Perl_dump_indent(aTHX_ level, file, "  LASTCLOSEPAREN = %"UVuf"\n",
2137                                 (UV)(r->lastcloseparen));
2138             Perl_dump_indent(aTHX_ level, file, "  MINLEN = %"IVdf"\n",
2139                                 (IV)(r->minlen));
2140             Perl_dump_indent(aTHX_ level, file, "  MINLENRET = %"IVdf"\n",
2141                                 (IV)(r->minlenret));
2142             Perl_dump_indent(aTHX_ level, file, "  GOFS = %"UVuf"\n",
2143                                 (UV)(r->gofs));
2144             Perl_dump_indent(aTHX_ level, file, "  PRE_PREFIX = %"UVuf"\n",
2145                                 (UV)(r->pre_prefix));
2146             Perl_dump_indent(aTHX_ level, file, "  SUBLEN = %"IVdf"\n",
2147                                 (IV)(r->sublen));
2148             Perl_dump_indent(aTHX_ level, file, "  SUBOFFSET = %"IVdf"\n",
2149                                 (IV)(r->suboffset));
2150             Perl_dump_indent(aTHX_ level, file, "  SUBCOFFSET = %"IVdf"\n",
2151                                 (IV)(r->subcoffset));
2152             if (r->subbeg)
2153                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x%"UVxf" %s\n",
2154                             PTR2UV(r->subbeg),
2155                             pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2156             else
2157                 Perl_dump_indent(aTHX_ level, file, "  SUBBEG = 0x0\n");
2158             Perl_dump_indent(aTHX_ level, file, "  MOTHER_RE = 0x%"UVxf"\n",
2159                                 PTR2UV(r->mother_re));
2160             if (nest < maxnest && r->mother_re)
2161                 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2162                            maxnest, dumpops, pvlim);
2163             Perl_dump_indent(aTHX_ level, file, "  PAREN_NAMES = 0x%"UVxf"\n",
2164                                 PTR2UV(r->paren_names));
2165             Perl_dump_indent(aTHX_ level, file, "  SUBSTRS = 0x%"UVxf"\n",
2166                                 PTR2UV(r->substrs));
2167             Perl_dump_indent(aTHX_ level, file, "  PPRIVATE = 0x%"UVxf"\n",
2168                                 PTR2UV(r->pprivate));
2169             Perl_dump_indent(aTHX_ level, file, "  OFFS = 0x%"UVxf"\n",
2170                                 PTR2UV(r->offs));
2171             Perl_dump_indent(aTHX_ level, file, "  QR_ANONCV = 0x%"UVxf"\n",
2172                                 PTR2UV(r->qr_anoncv));
2173 #ifdef PERL_ANY_COW
2174             Perl_dump_indent(aTHX_ level, file, "  SAVED_COPY = 0x%"UVxf"\n",
2175                                 PTR2UV(r->saved_copy));
2176 #endif
2177         }
2178         break;
2179     }
2180     SvREFCNT_dec_NN(d);
2181 }
2182
2183 /*
2184 =for apidoc sv_dump
2185
2186 Dumps the contents of an SV to the C<STDERR> filehandle.
2187
2188 For an example of its output, see L<Devel::Peek>.
2189
2190 =cut
2191 */
2192
2193 void
2194 Perl_sv_dump(pTHX_ SV *sv)
2195 {
2196     PERL_ARGS_ASSERT_SV_DUMP;
2197
2198     if (SvROK(sv))
2199         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2200     else
2201         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
2202 }
2203
2204 int
2205 Perl_runops_debug(pTHX)
2206 {
2207     if (!PL_op) {
2208         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
2209         return 0;
2210     }
2211
2212     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
2213     do {
2214 #ifdef PERL_TRACE_OPS
2215         ++PL_op_exec_cnt[PL_op->op_type];
2216 #endif
2217         if (PL_debug) {
2218             ENTER;
2219             SAVETMPS;
2220             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
2221                 PerlIO_printf(Perl_debug_log,
2222                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2223                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2224                               PTR2UV(*PL_watchaddr));
2225             if (DEBUG_s_TEST_) {
2226                 if (DEBUG_v_TEST_) {
2227                     PerlIO_printf(Perl_debug_log, "\n");
2228                     deb_stack_all();
2229                 }
2230                 else
2231                     debstack();
2232             }
2233
2234
2235             if (DEBUG_t_TEST_) debop(PL_op);
2236             if (DEBUG_P_TEST_) debprof(PL_op);
2237             FREETMPS;
2238             LEAVE;
2239         }
2240
2241         PERL_DTRACE_PROBE_OP(PL_op);
2242     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
2243     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
2244     PERL_ASYNC_CHECK();
2245
2246     TAINT_NOT;
2247     return 0;
2248 }
2249
2250
2251 /* print the names of the n lexical vars starting at pad offset off */
2252
2253 STATIC void
2254 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2255 {
2256     PADNAME *sv;
2257     CV * const cv = deb_curcv(cxstack_ix);
2258     PADNAMELIST *comppad = NULL;
2259     int i;
2260
2261     if (cv) {
2262         PADLIST * const padlist = CvPADLIST(cv);
2263         comppad = PadlistNAMES(padlist);
2264     }
2265     if (paren)
2266         PerlIO_printf(Perl_debug_log, "(");
2267     for (i = 0; i < n; i++) {
2268         if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2269             PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2270         else
2271             PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2272                     (UV)(off+i));
2273         if (i < n - 1)
2274             PerlIO_printf(Perl_debug_log, ",");
2275     }
2276     if (paren)
2277         PerlIO_printf(Perl_debug_log, ")");
2278 }
2279
2280
2281 /* append to the out SV, the name of the lexical at offset off in the CV
2282  * cv */
2283
2284 static void
2285 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2286         bool paren, bool is_scalar)
2287 {
2288     PADNAME *sv;
2289     PADNAMELIST *namepad = NULL;
2290     int i;
2291
2292     if (cv) {
2293         PADLIST * const padlist = CvPADLIST(cv);
2294         namepad = PadlistNAMES(padlist);
2295     }
2296
2297     if (paren)
2298         sv_catpvs_nomg(out, "(");
2299     for (i = 0; i < n; i++) {
2300         if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2301         {
2302             STRLEN cur = SvCUR(out);
2303             Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2304                                  UTF8fARG(1, PadnameLEN(sv) - 1,
2305                                           PadnamePV(sv) + 1));
2306             if (is_scalar)
2307                 SvPVX(out)[cur] = '$';
2308         }
2309         else
2310             Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2311         if (i < n - 1)
2312             sv_catpvs_nomg(out, ",");
2313     }
2314     if (paren)
2315         sv_catpvs_nomg(out, "(");
2316 }
2317
2318
2319 static void
2320 S_append_gv_name(pTHX_ GV *gv, SV *out)
2321 {
2322     SV *sv;
2323     if (!gv) {
2324         sv_catpvs_nomg(out, "<NULLGV>");
2325         return;
2326     }
2327     sv = newSV(0);
2328     gv_fullname4(sv, gv, NULL, FALSE);
2329     Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv));
2330     SvREFCNT_dec_NN(sv);
2331 }
2332
2333 #ifdef USE_ITHREADS
2334 #  define ITEM_SV(item) (comppad ? \
2335     *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
2336 #else
2337 #  define ITEM_SV(item) UNOP_AUX_item_sv(item)
2338 #endif
2339
2340
2341 /* return a temporary SV containing a stringified representation of
2342  * the op_aux field of a MULTIDEREF op, associated with CV cv
2343  */
2344
2345 SV*
2346 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
2347 {
2348     UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2349     UV actions = items->uv;
2350     SV *sv;
2351     bool last = 0;
2352     bool is_hash = FALSE;
2353     int derefs = 0;
2354     SV *out = newSVpvn_flags("",0,SVs_TEMP);
2355 #ifdef USE_ITHREADS
2356     PAD *comppad;
2357
2358     if (cv) {
2359         PADLIST *padlist = CvPADLIST(cv);
2360         comppad = PadlistARRAY(padlist)[1];
2361     }
2362     else
2363         comppad = NULL;
2364 #endif
2365
2366     PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
2367
2368     while (!last) {
2369         switch (actions & MDEREF_ACTION_MASK) {
2370
2371         case MDEREF_reload:
2372             actions = (++items)->uv;
2373             continue;
2374             NOT_REACHED; /* NOTREACHED */
2375
2376         case MDEREF_HV_padhv_helem:
2377             is_hash = TRUE;
2378             /* FALLTHROUGH */
2379         case MDEREF_AV_padav_aelem:
2380             derefs = 1;
2381             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2382             goto do_elem;
2383             NOT_REACHED; /* NOTREACHED */
2384
2385         case MDEREF_HV_gvhv_helem:
2386             is_hash = TRUE;
2387             /* FALLTHROUGH */
2388         case MDEREF_AV_gvav_aelem:
2389             derefs = 1;
2390             items++;
2391             sv = ITEM_SV(items);
2392             S_append_gv_name(aTHX_ (GV*)sv, out);
2393             goto do_elem;
2394             NOT_REACHED; /* NOTREACHED */
2395
2396         case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2397             is_hash = TRUE;
2398             /* FALLTHROUGH */
2399         case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2400             items++;
2401             sv = ITEM_SV(items);
2402             S_append_gv_name(aTHX_ (GV*)sv, out);
2403             goto do_vivify_rv2xv_elem;
2404             NOT_REACHED; /* NOTREACHED */
2405
2406         case MDEREF_HV_padsv_vivify_rv2hv_helem:
2407             is_hash = TRUE;
2408             /* FALLTHROUGH */
2409         case MDEREF_AV_padsv_vivify_rv2av_aelem:
2410             S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2411             goto do_vivify_rv2xv_elem;
2412             NOT_REACHED; /* NOTREACHED */
2413
2414         case MDEREF_HV_pop_rv2hv_helem:
2415         case MDEREF_HV_vivify_rv2hv_helem:
2416             is_hash = TRUE;
2417             /* FALLTHROUGH */
2418         do_vivify_rv2xv_elem:
2419         case MDEREF_AV_pop_rv2av_aelem:
2420         case MDEREF_AV_vivify_rv2av_aelem:
2421             if (!derefs++)
2422                 sv_catpvs_nomg(out, "->");
2423         do_elem:
2424             if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2425                 sv_catpvs_nomg(out, "->");
2426                 last = 1;
2427                 break;
2428             }
2429
2430             sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2431             switch (actions & MDEREF_INDEX_MASK) {
2432             case MDEREF_INDEX_const:
2433                 if (is_hash) {
2434                     items++;
2435                     sv = ITEM_SV(items);
2436                     if (!sv)
2437                         sv_catpvs_nomg(out, "???");
2438                     else {
2439                         STRLEN cur;
2440                         char *s;
2441                         s = SvPV(sv, cur);
2442                         pv_pretty(out, s, cur, 30,
2443                                     NULL, NULL,
2444                                     (PERL_PV_PRETTY_NOCLEAR
2445                                     |PERL_PV_PRETTY_QUOTE
2446                                     |PERL_PV_PRETTY_ELLIPSES));
2447                     }
2448                 }
2449                 else
2450                     Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2451                 break;
2452             case MDEREF_INDEX_padsv:
2453                 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2454                 break;
2455             case MDEREF_INDEX_gvsv:
2456                 items++;
2457                 sv = ITEM_SV(items);
2458                 S_append_gv_name(aTHX_ (GV*)sv, out);
2459                 break;
2460             }
2461             sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2462
2463             if (actions & MDEREF_FLAG_last)
2464                 last = 1;
2465             is_hash = FALSE;
2466
2467             break;
2468
2469         default:
2470             PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2471                 (int)(actions & MDEREF_ACTION_MASK));
2472             last = 1;
2473             break;
2474
2475         } /* switch */
2476
2477         actions >>= MDEREF_SHIFT;
2478     } /* while */
2479     return out;
2480 }
2481
2482
2483 I32
2484 Perl_debop(pTHX_ const OP *o)
2485 {
2486     PERL_ARGS_ASSERT_DEBOP;
2487
2488     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2489         return 0;
2490
2491     Perl_deb(aTHX_ "%s", OP_NAME(o));
2492     switch (o->op_type) {
2493     case OP_CONST:
2494     case OP_HINTSEVAL:
2495         /* With ITHREADS, consts are stored in the pad, and the right pad
2496          * may not be active here, so check.
2497          * Looks like only during compiling the pads are illegal.
2498          */
2499 #ifdef USE_ITHREADS
2500         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2501 #endif
2502             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2503         break;
2504     case OP_GVSV:
2505     case OP_GV:
2506         if (cGVOPo_gv && isGV(cGVOPo_gv)) {
2507             SV * const sv = newSV(0);
2508             gv_fullname3(sv, cGVOPo_gv, NULL);
2509             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2510             SvREFCNT_dec_NN(sv);
2511         }
2512         else if (cGVOPo_gv) {
2513             SV * const sv = newSV(0);
2514             assert(SvROK(cGVOPo_gv));
2515             assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2516             PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
2517                     SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
2518             SvREFCNT_dec_NN(sv);
2519         }
2520         else
2521             PerlIO_printf(Perl_debug_log, "(NULL)");
2522         break;
2523
2524     case OP_PADSV:
2525     case OP_PADAV:
2526     case OP_PADHV:
2527     case OP_ARGELEM:
2528         S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2529         break;
2530
2531     case OP_PADRANGE:
2532         S_deb_padvar(aTHX_ o->op_targ,
2533                         o->op_private & OPpPADRANGE_COUNTMASK, 1);
2534         break;
2535
2536     case OP_MULTIDEREF:
2537         PerlIO_printf(Perl_debug_log, "(%"SVf")",
2538             SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
2539         break;
2540
2541     default:
2542         break;
2543     }
2544     PerlIO_printf(Perl_debug_log, "\n");
2545     return 0;
2546 }
2547
2548 STATIC CV*
2549 S_deb_curcv(pTHX_ I32 ix)
2550 {
2551     PERL_SI *si = PL_curstackinfo;
2552     for (; ix >=0; ix--) {
2553         const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2554
2555         if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2556             return cx->blk_sub.cv;
2557         else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2558             return cx->blk_eval.cv;
2559         else if (ix == 0 && si->si_type == PERLSI_MAIN)
2560             return PL_main_cv;
2561         else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2562                && si->si_type == PERLSI_SORT)
2563         {
2564             /* fake sort sub; use CV of caller */
2565             si = si->si_prev;
2566             ix = si->si_cxix + 1;
2567         }
2568     }
2569     return NULL;
2570 }
2571
2572 void
2573 Perl_watch(pTHX_ char **addr)
2574 {
2575     PERL_ARGS_ASSERT_WATCH;
2576
2577     PL_watchaddr = addr;
2578     PL_watchok = *addr;
2579     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2580         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2581 }
2582
2583 STATIC void
2584 S_debprof(pTHX_ const OP *o)
2585 {
2586     PERL_ARGS_ASSERT_DEBPROF;
2587
2588     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2589         return;
2590     if (!PL_profiledata)
2591         Newxz(PL_profiledata, MAXO, U32);
2592     ++PL_profiledata[o->op_type];
2593 }
2594
2595 void
2596 Perl_debprofdump(pTHX)
2597 {
2598     unsigned i;
2599     if (!PL_profiledata)
2600         return;
2601     for (i = 0; i < MAXO; i++) {
2602         if (PL_profiledata[i])
2603             PerlIO_printf(Perl_debug_log,
2604                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2605                                        PL_op_name[i]);
2606     }
2607 }
2608
2609
2610 /*
2611  * ex: set ts=8 sts=4 sw=4 et:
2612  */