dump.c

   1 /*    dump.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 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
  16 /* This file contains utility routines to dump the contents of SV and OP
  17  * structures, as used by command-line options like -Dt and -Dx, and
  18  * by Devel::Peek.
  19  *
  20  * It also holds the debugging version of the  runops function.
  21  */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_DUMP_C
  25 #include "perl.h"
  26 #include "regcomp.h"
  27 #include "proto.h"
  28
  29
  30 static const char* const svtypenames[SVt_LAST] = {
  31     "NULL",
  32     "IV",
  33     "NV",
  34     "RV",
  35     "PV",
  36     "PVIV",
  37     "PVNV",
  38     "PVMG",
  39     "PVBM",
  40     "PVLV",
  41     "PVAV",
  42     "PVHV",
  43     "PVCV",
  44     "PVGV",
  45     "PVFM",
  46     "PVIO"
  47 };
  48
  49
  50 static const char* const svshorttypenames[SVt_LAST] = {
  51     "UNDEF",
  52     "IV",
  53     "NV",
  54     "RV",
  55     "PV",
  56     "PVIV",
  57     "PVNV",
  58     "PVMG",
  59     "BM",
  60     "PVLV",
  61     "AV",
  62     "HV",
  63     "CV",
  64     "GV",
  65     "FM",
  66     "IO"
  67 };
  68
  69 void
  70 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
  71 {
  72     va_list args;
  73     va_start(args, pat);
  74     dump_vindent(level, file, pat, &args);
  75     va_end(args);
  76 }
  77
  78 void
  79 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
  80 {
  81     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
  82     PerlIO_vprintf(file, pat, *args);
  83 }
  84
  85 void
  86 Perl_dump_all(pTHX)
  87 {
  88     PerlIO_setlinebuf(Perl_debug_log);
  89     if (PL_main_root)
  90         op_dump(PL_main_root);
  91     dump_packsubs(PL_defstash);
  92 }
  93
  94 void
  95 Perl_dump_packsubs(pTHX_ HV *stash)
  96 {
  97     I32 i;
  98
  99     if (!HvARRAY(stash))
 100         return;
 101     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 102         const HE *entry;
 103         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 104             const GV *gv = (GV*)HeVAL(entry);
 105             const HV *hv;
 106             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 107                 continue;
 108             if (GvCVu(gv))
 109                 dump_sub((GV *)gv);
 110             if (GvFORM(gv))
 111                 dump_form((GV *)gv);
 112             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
 113                 && (hv = GvHV(gv)) && hv != PL_defstash)
 114                 dump_packsubs((HV *) hv);               /* nested package */
 115         }
 116     }
 117 }
 118
 119 void
 120 Perl_dump_sub(pTHX_ GV *gv)
 121 {
 122     SV * const sv = sv_newmortal();
 123
 124     gv_fullname3(sv, gv, NULL);
 125     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
 126     if (CvISXSUB(GvCV(gv)))
 127         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
 128             PTR2UV(CvXSUB(GvCV(gv))),
 129             (int)CvXSUBANY(GvCV(gv)).any_i32);
 130     else if (CvROOT(GvCV(gv)))
 131         op_dump(CvROOT(GvCV(gv)));
 132     else
 133         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 134 }
 135
 136 void
 137 Perl_dump_form(pTHX_ GV *gv)
 138 {
 139     SV * const sv = sv_newmortal();
 140
 141     gv_fullname3(sv, gv, NULL);
 142     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
 143     if (CvROOT(GvFORM(gv)))
 144         op_dump(CvROOT(GvFORM(gv)));
 145     else
 146         Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 147 }
 148
 149 void
 150 Perl_dump_eval(pTHX)
 151 {
 152     op_dump(PL_eval_root);
 153 }
 154
 155
 156 /*
 157 =for apidoc Apd|char*|pv_escape|NN SV *dsv|NN const char const *str\
 158                |const STRLEN count|const STRLEN max
 159                |STRLEN const *escaped, const U32 flags
 160
 161 Escapes at most the first "count" chars of pv and puts the results into
 162 dsv such that the size of the escaped string will not exceed "max" chars
 163 and will not contain any incomplete escape sequences.
 164
 165 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string
 166 will also be escaped.
 167
 168 Normally the SV will be cleared before the escaped string is prepared,
 169 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur.
 170
 171 If PERL_PV_ESCAPE_UNI is set then the input string is treated as unicode,
 172 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned
 173 using C<is_utf8_string()> to determine if it is unicode.
 174
 175 If PERL_PV_ESCAPE_ALL is set then all input chars will be output
 176 using C<\x01F1> style escapes, otherwise only chars above 255 will be
 177 escaped using this style, other non printable chars will use octal or
 178 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH
 179 then all chars below 255 will be treated as printable and
 180 will be output as literals.
 181
 182 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the
 183 string will be escaped, regardles of max. If the string is utf8 and
 184 the chars value is >255 then it will be returned as a plain hex
 185 sequence. Thus the output will either be a single char,
 186 an octal escape sequence, a special escape like C<\n> or a 3 or
 187 more digit hex value.
 188
 189 Returns a pointer to the escaped text as held by dsv.
 190
 191 =cut
 192 */
 193 #define PV_ESCAPE_OCTBUFSIZE 32
 194
 195 char *
 196 Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
 197                 const STRLEN count, const STRLEN max,
 198                 STRLEN * const escaped, const U32 flags )
 199 {
 200     char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : '\\';
 201     char octbuf[PV_ESCAPE_OCTBUFSIZE] = "\\123456789ABCDF";
 202     STRLEN wrote = 0;    /* chars written so far */
 203     STRLEN chsize = 0;   /* size of data to be written */
 204     STRLEN readsize = 1; /* size of data just read */
 205     bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this unicode */
 206     const char *pv  = str;
 207     const char *end = pv + count; /* end of string */
 208
 209     if (!flags & PERL_PV_ESCAPE_NOCLEAR)
 210             sv_setpvn(dsv, "", 0);
 211
 212     if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
 213         isuni = 1;
 214
 215     for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
 216         const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv;
 217         const U8 c = (U8)u & 0xFF;
 218
 219         if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) {
 220             if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
 221                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 222                                       "%"UVxf, u);
 223             else
 224                 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 225                                       "\\x{%"UVxf"}", u);
 226         } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
 227             chsize = 1;
 228         } else {
 229             if ( (c == dq) || (c == '\\') || !isPRINT(c) ) {
 230             chsize = 2;
 231                 switch (c) {
 232                 case '\\' : octbuf[1] = '\\'; break;
 233                 case '\v' : octbuf[1] = 'v';  break;
 234                 case '\t' : octbuf[1] = 't';  break;
 235                 case '\r' : octbuf[1] = 'r';  break;
 236                 case '\n' : octbuf[1] = 'n';  break;
 237                 case '\f' : octbuf[1] = 'f';  break;
 238                     case '"'  :
 239                         if ( dq == '"' )
 240                                 octbuf[1] = '"';
 241                         else
 242                             chsize = 1;
 243                                 break;
 244                 default:
 245                         if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) )
 246                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 247                                                   "\\%03o", c);
 248                             else
 249                             chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
 250                                                   "\\%o", c);
 251                 }
 252             } else {
 253                 chsize=1;
 254             }
 255             }
 256             if ( max && (wrote + chsize > max) ) {
 257                 break;
 258         } else if (chsize > 1) {
 259                 sv_catpvn(dsv, octbuf, chsize);
 260                 wrote += chsize;
 261         } else {
 262             Perl_sv_catpvf( aTHX_ dsv, "%c", c);
 263             wrote++;
 264         }
 265         if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
 266             break;
 267     }
 268     if (escaped != NULL)
 269         *escaped= pv - str;
 270     return SvPVX(dsv);
 271 }
 272 /*
 273 =for apidoc Apd|char *|pv_pretty|NN SV *dsv|NN const char const *str\
 274            |const STRLEN count|const STRLEN max\
 275            |const char const *start_color| const char const *end_color\
 276            |const U32 flags
 277
 278 Converts a string into something presentable, handling escaping via
 279 pv_escape() and supporting quoting and elipses.
 280
 281 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be
 282 double quoted with any double quotes in the string escaped. Otherwise
 283 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in
 284 angle brackets.
 285
 286 If the PERL_PV_PRETTY_ELIPSES flag is set and not all characters in
 287 string were output then an elipses C<...> will be appended to the
 288 string. Note that this happens AFTER it has been quoted.
 289
 290 If start_color is non-null then it will be inserted after the opening
 291 quote (if there is one) but before the escaped text. If end_color
 292 is non-null then it will be inserted after the escaped text but before
 293 any quotes or elipses.
 294
 295 Returns a pointer to the prettified text as held by dsv.
 296
 297 =cut
 298 */
 299
 300 char *
 301 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
 302   const STRLEN max, char const * const start_color, char const * const end_color,
 303   const U32 flags )
 304 {
 305     U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '\\';
 306     STRLEN escaped;
 307
 308     if ( dq == '"' )
 309         sv_setpvn(dsv, "\"", 1);
 310     else if ( flags & PERL_PV_PRETTY_LTGT )
 311         sv_setpvn(dsv, "<", 1);
 312     else
 313         sv_setpvn(dsv, "", 0);
 314
 315     if ( start_color != NULL )
 316         Perl_sv_catpv( aTHX_ dsv, start_color);
 317
 318     pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
 319
 320     if ( end_color != NULL )
 321         Perl_sv_catpv( aTHX_ dsv, end_color);
 322
 323     if ( dq == '"' )
 324         sv_catpvn( dsv, "\"", 1 );
 325     else if ( flags & PERL_PV_PRETTY_LTGT )
 326         sv_catpvn( dsv, ">", 1);
 327
 328     if ( (flags & PERL_PV_PRETTY_ELIPSES) && ( escaped < count ) )
 329             sv_catpvn( dsv, "...", 3 );
 330
 331     return SvPVX(dsv);
 332 }
 333
 334 /*
 335 =for apidoc pv_display
 336
 337   char *pv_display(SV *dsv, const char *pv, STRLEN cur, STRLEN len,
 338                    STRLEN pvlim, U32 flags)
 339
 340 Similar to
 341
 342   pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
 343
 344 except that an additional "\0" will be appended to the string when
 345 len > cur and pv[cur] is "\0".
 346
 347 Note that the final string may be up to 7 chars longer than pvlim.
 348
 349 =cut
 350 */
 351
 352 char *
 353 Perl_pv_display(pTHX_ SV *dsv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
 354 {
 355     pv_pretty( dsv, (char *)pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
 356     if (len > cur && pv[cur] == '\0')
 357             sv_catpvn( dsv, "\\0", 2 );
 358     return SvPVX(dsv);
 359 }
 360
 361 char *
 362 Perl_sv_peek(pTHX_ SV *sv)
 363 {
 364     SV * const t = sv_newmortal();
 365     int unref = 0;
 366     U32 type;
 367
 368     sv_setpvn(t, "", 0);
 369   retry:
 370     if (!sv) {
 371         sv_catpv(t, "VOID");
 372         goto finish;
 373     }
 374     else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
 375         sv_catpv(t, "WILD");
 376         goto finish;
 377     }
 378     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
 379         if (sv == &PL_sv_undef) {
 380             sv_catpv(t, "SV_UNDEF");
 381             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 382                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 383                 SvREADONLY(sv))
 384                 goto finish;
 385         }
 386         else if (sv == &PL_sv_no) {
 387             sv_catpv(t, "SV_NO");
 388             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 389                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 390                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 391                                   SVp_POK|SVp_NOK)) &&
 392                 SvCUR(sv) == 0 &&
 393                 SvNVX(sv) == 0.0)
 394                 goto finish;
 395         }
 396         else if (sv == &PL_sv_yes) {
 397             sv_catpv(t, "SV_YES");
 398             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
 399                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 400                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
 401                                   SVp_POK|SVp_NOK)) &&
 402                 SvCUR(sv) == 1 &&
 403                 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
 404                 SvNVX(sv) == 1.0)
 405                 goto finish;
 406         }
 407         else {
 408             sv_catpv(t, "SV_PLACEHOLDER");
 409             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 410                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
 411                 SvREADONLY(sv))
 412                 goto finish;
 413         }
 414         sv_catpv(t, ":");
 415     }
 416     else if (SvREFCNT(sv) == 0) {
 417         sv_catpv(t, "(");
 418         unref++;
 419     }
 420     else if (DEBUG_R_TEST_) {
 421         int is_tmp = 0;
 422         I32 ix;
 423         /* is this SV on the tmps stack? */
 424         for (ix=PL_tmps_ix; ix>=0; ix--) {
 425             if (PL_tmps_stack[ix] == sv) {
 426                 is_tmp = 1;
 427                 break;
 428             }
 429         }
 430         if (SvREFCNT(sv) > 1)
 431             Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
 432                     is_tmp ? "T" : "");
 433         else if (is_tmp)
 434             sv_catpv(t, "<T>");
 435     }
 436
 437     if (SvROK(sv)) {
 438         sv_catpv(t, "\\");
 439         if (SvCUR(t) + unref > 10) {
 440             SvCUR_set(t, unref + 3);
 441             *SvEND(t) = '\0';
 442             sv_catpv(t, "...");
 443             goto finish;
 444         }
 445         sv = (SV*)SvRV(sv);
 446         goto retry;
 447     }
 448     type = SvTYPE(sv);
 449     if (type == SVt_PVCV) {
 450         Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : "");
 451         goto finish;
 452     } else if (type < SVt_LAST) {
 453         sv_catpv(t, svshorttypenames[type]);
 454
 455         if (type == SVt_NULL)
 456             goto finish;
 457     } else {
 458         sv_catpv(t, "FREED");
 459         goto finish;
 460     }
 461
 462     if (SvPOKp(sv)) {
 463         if (!SvPVX_const(sv))
 464             sv_catpv(t, "(null)");
 465         else {
 466             SV * const tmp = newSVpvs("");
 467             sv_catpv(t, "(");
 468             if (SvOOK(sv))
 469                 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, (char *)SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127));
 470             Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, (char *)SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
 471             if (SvUTF8(sv))
 472                 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
 473                                sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv),
 474                                               UNI_DISPLAY_QQ));
 475             SvREFCNT_dec(tmp);
 476         }
 477     }
 478     else if (SvNOKp(sv)) {
 479         STORE_NUMERIC_LOCAL_SET_STANDARD();
 480         Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
 481         RESTORE_NUMERIC_LOCAL();
 482     }
 483     else if (SvIOKp(sv)) {
 484         if (SvIsUV(sv))
 485             Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
 486         else
 487             Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
 488     }
 489     else
 490         sv_catpv(t, "()");
 491
 492   finish:
 493     if (unref) {
 494         while (unref--)
 495             sv_catpv(t, ")");
 496     }
 497     return SvPV_nolen(t);
 498 }
 499
 500 void
 501 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm)
 502 {
 503     char ch;
 504
 505     if (!pm) {
 506         Perl_dump_indent(aTHX_ level, file, "{}\n");
 507         return;
 508     }
 509     Perl_dump_indent(aTHX_ level, file, "{\n");
 510     level++;
 511     if (pm->op_pmflags & PMf_ONCE)
 512         ch = '?';
 513     else
 514         ch = '/';
 515     if (PM_GETRE(pm))
 516         Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n",
 517              ch, PM_GETRE(pm)->precomp, ch,
 518              (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
 519     else
 520         Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
 521     if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
 522         Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
 523         op_dump(pm->op_pmreplroot);
 524     }
 525     if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) {
 526         SV * const tmpsv = pm_description(pm);
 527         Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 528         SvREFCNT_dec(tmpsv);
 529     }
 530
 531     Perl_dump_indent(aTHX_ level-1, file, "}\n");
 532 }
 533
 534 static SV *
 535 S_pm_description(pTHX_ const PMOP *pm)
 536 {
 537     SV * const desc = newSVpvs("");
 538     const REGEXP * regex = PM_GETRE(pm);
 539     const U32 pmflags = pm->op_pmflags;
 540
 541     if (pm->op_pmdynflags & PMdf_USED)
 542         sv_catpv(desc, ",USED");
 543     if (pm->op_pmdynflags & PMdf_TAINTED)
 544         sv_catpv(desc, ",TAINTED");
 545
 546     if (pmflags & PMf_ONCE)
 547         sv_catpv(desc, ",ONCE");
 548     if (regex && regex->check_substr) {
 549         if (!(regex->reganch & ROPT_NOSCAN))
 550             sv_catpv(desc, ",SCANFIRST");
 551         if (regex->reganch & ROPT_CHECK_ALL)
 552             sv_catpv(desc, ",ALL");
 553     }
 554     if (pmflags & PMf_SKIPWHITE)
 555         sv_catpv(desc, ",SKIPWHITE");
 556     if (pmflags & PMf_CONST)
 557         sv_catpv(desc, ",CONST");
 558     if (pmflags & PMf_KEEP)
 559         sv_catpv(desc, ",KEEP");
 560     if (pmflags & PMf_GLOBAL)
 561         sv_catpv(desc, ",GLOBAL");
 562     if (pmflags & PMf_CONTINUE)
 563         sv_catpv(desc, ",CONTINUE");
 564     if (pmflags & PMf_RETAINT)
 565         sv_catpv(desc, ",RETAINT");
 566     if (pmflags & PMf_EVAL)
 567         sv_catpv(desc, ",EVAL");
 568     return desc;
 569 }
 570
 571 void
 572 Perl_pmop_dump(pTHX_ PMOP *pm)
 573 {
 574     do_pmop_dump(0, Perl_debug_log, pm);
 575 }
 576
 577 void
 578 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
 579 {
 580     const OPCODE optype = o->op_type;
 581
 582     Perl_dump_indent(aTHX_ level, file, "{\n");
 583     level++;
 584     if (o->op_seq)
 585         PerlIO_printf(file, "%-4d", o->op_seq);
 586     else
 587         PerlIO_printf(file, "    ");
 588     PerlIO_printf(file,
 589                   "%*sTYPE = %s  ===> ",
 590                   (int)(PL_dumpindent*level-4), "", OP_NAME(o));
 591     if (o->op_next) {
 592         if (o->op_seq)
 593             PerlIO_printf(file, "%d\n", o->op_next->op_seq);
 594         else
 595             PerlIO_printf(file, "(%d)\n", o->op_next->op_seq);
 596     }
 597     else
 598         PerlIO_printf(file, "DONE\n");
 599     if (o->op_targ) {
 600         if (optype == OP_NULL) {
 601             Perl_dump_indent(aTHX_ level, file, "  (was %s)\n", PL_op_name[o->op_targ]);
 602             if (o->op_targ == OP_NEXTSTATE) {
 603                 if (CopLINE(cCOPo))
 604                     Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
 605                                      (UV)CopLINE(cCOPo));
 606                 if (CopSTASHPV(cCOPo))
 607                     Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
 608                                      CopSTASHPV(cCOPo));
 609                 if (cCOPo->cop_label)
 610                     Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
 611                                      cCOPo->cop_label);
 612             }
 613         }
 614         else
 615             Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
 616     }
 617 #ifdef DUMPADDR
 618     Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
 619 #endif
 620     if (o->op_flags) {
 621         SV * const tmpsv = newSVpvs("");
 622         switch (o->op_flags & OPf_WANT) {
 623         case OPf_WANT_VOID:
 624             sv_catpv(tmpsv, ",VOID");
 625             break;
 626         case OPf_WANT_SCALAR:
 627             sv_catpv(tmpsv, ",SCALAR");
 628             break;
 629         case OPf_WANT_LIST:
 630             sv_catpv(tmpsv, ",LIST");
 631             break;
 632         default:
 633             sv_catpv(tmpsv, ",UNKNOWN");
 634             break;
 635         }
 636         if (o->op_flags & OPf_KIDS)
 637             sv_catpv(tmpsv, ",KIDS");
 638         if (o->op_flags & OPf_PARENS)
 639             sv_catpv(tmpsv, ",PARENS");
 640         if (o->op_flags & OPf_STACKED)
 641             sv_catpv(tmpsv, ",STACKED");
 642         if (o->op_flags & OPf_REF)
 643             sv_catpv(tmpsv, ",REF");
 644         if (o->op_flags & OPf_MOD)
 645             sv_catpv(tmpsv, ",MOD");
 646         if (o->op_flags & OPf_SPECIAL)
 647             sv_catpv(tmpsv, ",SPECIAL");
 648         Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
 649         SvREFCNT_dec(tmpsv);
 650     }
 651     if (o->op_private) {
 652         SV * const tmpsv = newSVpvs("");
 653         if (PL_opargs[optype] & OA_TARGLEX) {
 654             if (o->op_private & OPpTARGET_MY)
 655                 sv_catpv(tmpsv, ",TARGET_MY");
 656         }
 657         else if (optype == OP_LEAVESUB ||
 658                  optype == OP_LEAVE ||
 659                  optype == OP_LEAVESUBLV ||
 660                  optype == OP_LEAVEWRITE) {
 661             if (o->op_private & OPpREFCOUNTED)
 662                 sv_catpv(tmpsv, ",REFCOUNTED");
 663         }
 664         else if (optype == OP_AASSIGN) {
 665             if (o->op_private & OPpASSIGN_COMMON)
 666                 sv_catpv(tmpsv, ",COMMON");
 667             if (o->op_private & OPpASSIGN_HASH)
 668                 sv_catpv(tmpsv, ",HASH");
 669         }
 670         else if (optype == OP_SASSIGN) {
 671             if (o->op_private & OPpASSIGN_BACKWARDS)
 672                 sv_catpv(tmpsv, ",BACKWARDS");
 673         }
 674         else if (optype == OP_TRANS) {
 675             if (o->op_private & OPpTRANS_SQUASH)
 676                 sv_catpv(tmpsv, ",SQUASH");
 677             if (o->op_private & OPpTRANS_DELETE)
 678                 sv_catpv(tmpsv, ",DELETE");
 679             if (o->op_private & OPpTRANS_COMPLEMENT)
 680                 sv_catpv(tmpsv, ",COMPLEMENT");
 681             if (o->op_private & OPpTRANS_IDENTICAL)
 682                 sv_catpv(tmpsv, ",IDENTICAL");
 683             if (o->op_private & OPpTRANS_GROWS)
 684                 sv_catpv(tmpsv, ",GROWS");
 685         }
 686         else if (optype == OP_REPEAT) {
 687             if (o->op_private & OPpREPEAT_DOLIST)
 688                 sv_catpv(tmpsv, ",DOLIST");
 689         }
 690         else if (optype == OP_ENTERSUB ||
 691                  optype == OP_RV2SV ||
 692                  optype == OP_GVSV ||
 693                  optype == OP_RV2AV ||
 694                  optype == OP_RV2HV ||
 695                  optype == OP_RV2GV ||
 696                  optype == OP_AELEM ||
 697                  optype == OP_HELEM )
 698         {
 699             if (optype == OP_ENTERSUB) {
 700                 if (o->op_private & OPpENTERSUB_AMPER)
 701                     sv_catpv(tmpsv, ",AMPER");
 702                 if (o->op_private & OPpENTERSUB_DB)
 703                     sv_catpv(tmpsv, ",DB");
 704                 if (o->op_private & OPpENTERSUB_HASTARG)
 705                     sv_catpv(tmpsv, ",HASTARG");
 706                 if (o->op_private & OPpENTERSUB_NOPAREN)
 707                     sv_catpv(tmpsv, ",NOPAREN");
 708                 if (o->op_private & OPpENTERSUB_INARGS)
 709                     sv_catpv(tmpsv, ",INARGS");
 710                 if (o->op_private & OPpENTERSUB_NOMOD)
 711                     sv_catpv(tmpsv, ",NOMOD");
 712             }
 713             else {
 714                 switch (o->op_private & OPpDEREF) {
 715                 case OPpDEREF_SV:
 716                     sv_catpv(tmpsv, ",SV");
 717                     break;
 718                 case OPpDEREF_AV:
 719                     sv_catpv(tmpsv, ",AV");
 720                     break;
 721                 case OPpDEREF_HV:
 722                     sv_catpv(tmpsv, ",HV");
 723                     break;
 724                 }
 725                 if (o->op_private & OPpMAYBE_LVSUB)
 726                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
 727             }
 728             if (optype == OP_AELEM || optype == OP_HELEM) {
 729                 if (o->op_private & OPpLVAL_DEFER)
 730                     sv_catpv(tmpsv, ",LVAL_DEFER");
 731             }
 732             else {
 733                 if (o->op_private & HINT_STRICT_REFS)
 734                     sv_catpv(tmpsv, ",STRICT_REFS");
 735                 if (o->op_private & OPpOUR_INTRO)
 736                     sv_catpv(tmpsv, ",OUR_INTRO");
 737             }
 738         }
 739         else if (optype == OP_CONST) {
 740             if (o->op_private & OPpCONST_BARE)
 741                 sv_catpv(tmpsv, ",BARE");
 742             if (o->op_private & OPpCONST_STRICT)
 743                 sv_catpv(tmpsv, ",STRICT");
 744             if (o->op_private & OPpCONST_ARYBASE)
 745                 sv_catpv(tmpsv, ",ARYBASE");
 746             if (o->op_private & OPpCONST_WARNING)
 747                 sv_catpv(tmpsv, ",WARNING");
 748             if (o->op_private & OPpCONST_ENTERED)
 749                 sv_catpv(tmpsv, ",ENTERED");
 750         }
 751         else if (optype == OP_FLIP) {
 752             if (o->op_private & OPpFLIP_LINENUM)
 753                 sv_catpv(tmpsv, ",LINENUM");
 754         }
 755         else if (optype == OP_FLOP) {
 756             if (o->op_private & OPpFLIP_LINENUM)
 757                 sv_catpv(tmpsv, ",LINENUM");
 758         }
 759         else if (optype == OP_RV2CV) {
 760             if (o->op_private & OPpLVAL_INTRO)
 761                 sv_catpv(tmpsv, ",INTRO");
 762         }
 763         else if (optype == OP_GV) {
 764             if (o->op_private & OPpEARLY_CV)
 765                 sv_catpv(tmpsv, ",EARLY_CV");
 766         }
 767         else if (optype == OP_LIST) {
 768             if (o->op_private & OPpLIST_GUESSED)
 769                 sv_catpv(tmpsv, ",GUESSED");
 770         }
 771         else if (optype == OP_DELETE) {
 772             if (o->op_private & OPpSLICE)
 773                 sv_catpv(tmpsv, ",SLICE");
 774         }
 775         else if (optype == OP_EXISTS) {
 776             if (o->op_private & OPpEXISTS_SUB)
 777                 sv_catpv(tmpsv, ",EXISTS_SUB");
 778         }
 779         else if (optype == OP_SORT) {
 780             if (o->op_private & OPpSORT_NUMERIC)
 781                 sv_catpv(tmpsv, ",NUMERIC");
 782             if (o->op_private & OPpSORT_INTEGER)
 783                 sv_catpv(tmpsv, ",INTEGER");
 784             if (o->op_private & OPpSORT_REVERSE)
 785                 sv_catpv(tmpsv, ",REVERSE");
 786         }
 787         else if (optype == OP_THREADSV) {
 788             if (o->op_private & OPpDONE_SVREF)
 789                 sv_catpv(tmpsv, ",SVREF");
 790         }
 791         else if (optype == OP_OPEN || optype == OP_BACKTICK) {
 792             if (o->op_private & OPpOPEN_IN_RAW)
 793                 sv_catpv(tmpsv, ",IN_RAW");
 794             if (o->op_private & OPpOPEN_IN_CRLF)
 795                 sv_catpv(tmpsv, ",IN_CRLF");
 796             if (o->op_private & OPpOPEN_OUT_RAW)
 797                 sv_catpv(tmpsv, ",OUT_RAW");
 798             if (o->op_private & OPpOPEN_OUT_CRLF)
 799                 sv_catpv(tmpsv, ",OUT_CRLF");
 800         }
 801         else if (optype == OP_EXIT) {
 802             if (o->op_private & OPpEXIT_VMSISH)
 803                 sv_catpv(tmpsv, ",EXIT_VMSISH");
 804             if (o->op_private & OPpHUSH_VMSISH)
 805                 sv_catpv(tmpsv, ",HUSH_VMSISH");
 806         }
 807         else if (optype == OP_DIE) {
 808             if (o->op_private & OPpHUSH_VMSISH)
 809                 sv_catpv(tmpsv, ",HUSH_VMSISH");
 810         }
 811         else if (OP_IS_FILETEST_ACCESS(o)) {
 812              if (o->op_private & OPpFT_ACCESS)
 813                   sv_catpv(tmpsv, ",FT_ACCESS");
 814         }
 815         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
 816             sv_catpv(tmpsv, ",INTRO");
 817         if (SvCUR(tmpsv))
 818             Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
 819         SvREFCNT_dec(tmpsv);
 820     }
 821
 822     switch (optype) {
 823     case OP_AELEMFAST:
 824     case OP_GVSV:
 825     case OP_GV:
 826 #ifdef USE_ITHREADS
 827         Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
 828 #else
 829         if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
 830             if (cSVOPo->op_sv) {
 831                 SV * const tmpsv = newSV(0);
 832                 ENTER;
 833                 SAVEFREESV(tmpsv);
 834                 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, NULL);
 835                 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
 836                                  SvPV_nolen_const(tmpsv));
 837                 LEAVE;
 838             }
 839             else
 840                 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
 841         }
 842 #endif
 843         break;
 844     case OP_CONST:
 845     case OP_METHOD_NAMED:
 846 #ifndef USE_ITHREADS
 847         /* with ITHREADS, consts are stored in the pad, and the right pad
 848          * may not be active here, so skip */
 849         Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
 850 #endif
 851         break;
 852     case OP_SETSTATE:
 853     case OP_NEXTSTATE:
 854     case OP_DBSTATE:
 855         if (CopLINE(cCOPo))
 856             Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
 857                              (UV)CopLINE(cCOPo));
 858         if (CopSTASHPV(cCOPo))
 859             Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
 860                              CopSTASHPV(cCOPo));
 861         if (cCOPo->cop_label)
 862             Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
 863                              cCOPo->cop_label);
 864         break;
 865     case OP_ENTERLOOP:
 866         Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
 867         if (cLOOPo->op_redoop)
 868             PerlIO_printf(file, "%d\n", cLOOPo->op_redoop->op_seq);
 869         else
 870             PerlIO_printf(file, "DONE\n");
 871         Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
 872         if (cLOOPo->op_nextop)
 873             PerlIO_printf(file, "%d\n", cLOOPo->op_nextop->op_seq);
 874         else
 875             PerlIO_printf(file, "DONE\n");
 876         Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
 877         if (cLOOPo->op_lastop)
 878             PerlIO_printf(file, "%d\n", cLOOPo->op_lastop->op_seq);
 879         else
 880             PerlIO_printf(file, "DONE\n");
 881         break;
 882     case OP_COND_EXPR:
 883     case OP_RANGE:
 884     case OP_MAPWHILE:
 885     case OP_GREPWHILE:
 886     case OP_OR:
 887     case OP_AND:
 888         Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
 889         if (cLOGOPo->op_other)
 890             PerlIO_printf(file, "%d\n", cLOGOPo->op_other->op_seq);
 891         else
 892             PerlIO_printf(file, "DONE\n");
 893         break;
 894     case OP_PUSHRE:
 895     case OP_MATCH:
 896     case OP_QR:
 897     case OP_SUBST:
 898         do_pmop_dump(level, file, cPMOPo);
 899         break;
 900     case OP_LEAVE:
 901     case OP_LEAVEEVAL:
 902     case OP_LEAVESUB:
 903     case OP_LEAVESUBLV:
 904     case OP_LEAVEWRITE:
 905     case OP_SCOPE:
 906         if (o->op_private & OPpREFCOUNTED)
 907             Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
 908         break;
 909     default:
 910         break;
 911     }
 912     if (o->op_flags & OPf_KIDS) {
 913         OP *kid;
 914         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 915             do_op_dump(level, file, kid);
 916     }
 917     Perl_dump_indent(aTHX_ level-1, file, "}\n");
 918 }
 919
 920 void
 921 Perl_op_dump(pTHX_ OP *o)
 922 {
 923     do_op_dump(0, Perl_debug_log, o);
 924 }
 925
 926 void
 927 Perl_gv_dump(pTHX_ GV *gv)
 928 {
 929     SV *sv;
 930
 931     if (!gv) {
 932         PerlIO_printf(Perl_debug_log, "{}\n");
 933         return;
 934     }
 935     sv = sv_newmortal();
 936     PerlIO_printf(Perl_debug_log, "{\n");
 937     gv_fullname3(sv, gv, NULL);
 938     Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv));
 939     if (gv != GvEGV(gv)) {
 940         gv_efullname3(sv, GvEGV(gv), NULL);
 941         Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv));
 942     }
 943     PerlIO_putc(Perl_debug_log, '\n');
 944     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
 945 }
 946
 947
 948 /* map magic types to the symbolic names
 949  * (with the PERL_MAGIC_ prefixed stripped)
 950  */
 951
 952 static const struct { const char type; const char *name; } magic_names[] = {
 953         { PERL_MAGIC_sv,             "sv(\\0)" },
 954         { PERL_MAGIC_arylen,         "arylen(#)" },
 955         { PERL_MAGIC_glob,           "glob(*)" },
 956         { PERL_MAGIC_pos,            "pos(.)" },
 957         { PERL_MAGIC_backref,        "backref(<)" },
 958         { PERL_MAGIC_overload,       "overload(A)" },
 959         { PERL_MAGIC_bm,             "bm(B)" },
 960         { PERL_MAGIC_regdata,        "regdata(D)" },
 961         { PERL_MAGIC_env,            "env(E)" },
 962         { PERL_MAGIC_isa,            "isa(I)" },
 963         { PERL_MAGIC_dbfile,         "dbfile(L)" },
 964         { PERL_MAGIC_shared,         "shared(N)" },
 965         { PERL_MAGIC_tied,           "tied(P)" },
 966         { PERL_MAGIC_sig,            "sig(S)" },
 967         { PERL_MAGIC_uvar,           "uvar(U)" },
 968         { PERL_MAGIC_overload_elem,  "overload_elem(a)" },
 969         { PERL_MAGIC_overload_table, "overload_table(c)" },
 970         { PERL_MAGIC_regdatum,       "regdatum(d)" },
 971         { PERL_MAGIC_envelem,        "envelem(e)" },
 972         { PERL_MAGIC_fm,             "fm(f)" },
 973         { PERL_MAGIC_regex_global,   "regex_global(g)" },
 974         { PERL_MAGIC_isaelem,        "isaelem(i)" },
 975         { PERL_MAGIC_nkeys,          "nkeys(k)" },
 976         { PERL_MAGIC_dbline,         "dbline(l)" },
 977         { PERL_MAGIC_mutex,          "mutex(m)" },
 978         { PERL_MAGIC_shared_scalar,  "shared_scalar(n)" },
 979         { PERL_MAGIC_collxfrm,       "collxfrm(o)" },
 980         { PERL_MAGIC_tiedelem,       "tiedelem(p)" },
 981         { PERL_MAGIC_tiedscalar,     "tiedscalar(q)" },
 982         { PERL_MAGIC_qr,             "qr(r)" },
 983         { PERL_MAGIC_sigelem,        "sigelem(s)" },
 984         { PERL_MAGIC_taint,          "taint(t)" },
 985         { PERL_MAGIC_uvar_elem,      "uvar_elem(v)" },
 986         { PERL_MAGIC_vec,            "vec(v)" },
 987         { PERL_MAGIC_vstring,        "v-string(V)" },
 988         { PERL_MAGIC_utf8,           "utf8(w)" },
 989         { PERL_MAGIC_substr,         "substr(x)" },
 990         { PERL_MAGIC_defelem,        "defelem(y)" },
 991         { PERL_MAGIC_ext,            "ext(~)" },
 992         /* this null string terminates the list */
 993         { 0,                         NULL },
 994 };
 995
 996 void
 997 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
 998 {
 999     for (; mg; mg = mg->mg_moremagic) {
1000         Perl_dump_indent(aTHX_ level, file,
1001                          "  MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
1002         if (mg->mg_virtual) {
1003             const MGVTBL * const v = mg->mg_virtual;
1004             const char *s;
1005             if      (v == &PL_vtbl_sv)         s = "sv";
1006             else if (v == &PL_vtbl_env)        s = "env";
1007             else if (v == &PL_vtbl_envelem)    s = "envelem";
1008             else if (v == &PL_vtbl_sig)        s = "sig";
1009             else if (v == &PL_vtbl_sigelem)    s = "sigelem";
1010             else if (v == &PL_vtbl_pack)       s = "pack";
1011             else if (v == &PL_vtbl_packelem)   s = "packelem";
1012             else if (v == &PL_vtbl_dbline)     s = "dbline";
1013             else if (v == &PL_vtbl_isa)        s = "isa";
1014             else if (v == &PL_vtbl_arylen)     s = "arylen";
1015             else if (v == &PL_vtbl_glob)       s = "glob";
1016             else if (v == &PL_vtbl_mglob)      s = "mglob";
1017             else if (v == &PL_vtbl_nkeys)      s = "nkeys";
1018             else if (v == &PL_vtbl_taint)      s = "taint";
1019             else if (v == &PL_vtbl_substr)     s = "substr";
1020             else if (v == &PL_vtbl_vec)        s = "vec";
1021             else if (v == &PL_vtbl_pos)        s = "pos";
1022             else if (v == &PL_vtbl_bm)         s = "bm";
1023             else if (v == &PL_vtbl_fm)         s = "fm";
1024             else if (v == &PL_vtbl_uvar)       s = "uvar";
1025             else if (v == &PL_vtbl_defelem)    s = "defelem";
1026 #ifdef USE_LOCALE_COLLATE
1027             else if (v == &PL_vtbl_collxfrm)   s = "collxfrm";
1028 #endif
1029             else if (v == &PL_vtbl_amagic)     s = "amagic";
1030             else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
1031             else if (v == &PL_vtbl_backref)    s = "backref";
1032             else if (v == &PL_vtbl_utf8)       s = "utf8";
1033             else                               s = NULL;
1034             if (s)
1035                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
1036             else
1037                 Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
1038         }
1039         else
1040             Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = 0\n");
1041
1042         if (mg->mg_private)
1043             Perl_dump_indent(aTHX_ level, file, "    MG_PRIVATE = %d\n", mg->mg_private);
1044
1045         {
1046             int n;
1047             const char *name = NULL;
1048             for (n = 0; magic_names[n].name; n++) {
1049                 if (mg->mg_type == magic_names[n].type) {
1050                     name = magic_names[n].name;
1051                     break;
1052                 }
1053             }
1054             if (name)
1055                 Perl_dump_indent(aTHX_ level, file,
1056                                 "    MG_TYPE = PERL_MAGIC_%s\n", name);
1057             else
1058                 Perl_dump_indent(aTHX_ level, file,
1059                                 "    MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1060         }
1061
1062         if (mg->mg_flags) {
1063             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
1064             if (mg->mg_type == PERL_MAGIC_envelem &&
1065                 mg->mg_flags & MGf_TAINTEDDIR)
1066                 Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
1067             if (mg->mg_flags & MGf_REFCOUNTED)
1068                 Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
1069             if (mg->mg_flags & MGf_GSKIP)
1070                 Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
1071             if (mg->mg_type == PERL_MAGIC_regex_global &&
1072                 mg->mg_flags & MGf_MINMATCH)
1073                 Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
1074         }
1075         if (mg->mg_obj) {
1076             Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1077             if (mg->mg_flags & MGf_REFCOUNTED)
1078                 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1079         }
1080         if (mg->mg_len)
1081             Perl_dump_indent(aTHX_ level, file, "    MG_LEN = %ld\n", (long)mg->mg_len);
1082         if (mg->mg_ptr) {
1083             Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
1084             if (mg->mg_len >= 0) {
1085                 if (mg->mg_type != PERL_MAGIC_utf8) {
1086                     SV *sv = newSVpvs("");
1087                     PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
1088                     SvREFCNT_dec(sv);
1089                 }
1090             }
1091             else if (mg->mg_len == HEf_SVKEY) {
1092                 PerlIO_puts(file, " => HEf_SVKEY\n");
1093                 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1094                 continue;
1095             }
1096             else
1097                 PerlIO_puts(file, " ???? - please notify IZ");
1098             PerlIO_putc(file, '\n');
1099         }
1100         if (mg->mg_type == PERL_MAGIC_utf8) {
1101              STRLEN *cache = (STRLEN *) mg->mg_ptr;
1102              if (cache) {
1103                   IV i;
1104                   for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1105                        Perl_dump_indent(aTHX_ level, file,
1106                                         "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
1107                                         i,
1108                                         (UV)cache[i * 2],
1109                                         (UV)cache[i * 2 + 1]);
1110              }
1111         }
1112     }
1113 }
1114
1115 void
1116 Perl_magic_dump(pTHX_ MAGIC *mg)
1117 {
1118     do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
1119 }
1120
1121 void
1122 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, char *name, HV *sv)
1123 {
1124     const char *hvname;
1125     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1126     if (sv && (hvname = HvNAME_get(sv)))
1127         PerlIO_printf(file, "\t\"%s\"\n", hvname);
1128     else
1129         PerlIO_putc(file, '\n');
1130 }
1131
1132 void
1133 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv)
1134 {
1135     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1136     if (sv && GvNAME(sv))
1137         PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv));
1138     else
1139         PerlIO_putc(file, '\n');
1140 }
1141
1142 void
1143 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv)
1144 {
1145     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
1146     if (sv && GvNAME(sv)) {
1147         const char *hvname;
1148         PerlIO_printf(file, "\t\"");
1149         if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv))))
1150             PerlIO_printf(file, "%s\" :: \"", hvname);
1151         PerlIO_printf(file, "%s\"\n", GvNAME(sv));
1152     }
1153     else
1154         PerlIO_putc(file, '\n');
1155 }
1156
1157 void
1158 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
1159 {
1160     SV *d;
1161     const char *s;
1162     U32 flags;
1163     U32 type;
1164
1165     if (!sv) {
1166         Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
1167         return;
1168     }
1169
1170     flags = SvFLAGS(sv);
1171     type = SvTYPE(sv);
1172
1173     d = Perl_newSVpvf(aTHX_
1174                    "(0x%"UVxf") at 0x%"UVxf"\n%*s  REFCNT = %"IVdf"\n%*s  FLAGS = (",
1175                    PTR2UV(SvANY(sv)), PTR2UV(sv),
1176                    (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1177                    (int)(PL_dumpindent*level), "");
1178
1179     if (flags & SVs_PADBUSY)    sv_catpv(d, "PADBUSY,");
1180     if (flags & SVs_PADTMP)     sv_catpv(d, "PADTMP,");
1181     if (flags & SVs_PADMY)      sv_catpv(d, "PADMY,");
1182     if (flags & SVs_TEMP)       sv_catpv(d, "TEMP,");
1183     if (flags & SVs_OBJECT)     sv_catpv(d, "OBJECT,");
1184     if (flags & SVs_GMG)        sv_catpv(d, "GMG,");
1185     if (flags & SVs_SMG)        sv_catpv(d, "SMG,");
1186     if (flags & SVs_RMG)        sv_catpv(d, "RMG,");
1187
1188     if (flags & SVf_IOK)        sv_catpv(d, "IOK,");
1189     if (flags & SVf_NOK)        sv_catpv(d, "NOK,");
1190     if (flags & SVf_POK)        sv_catpv(d, "POK,");
1191     if (flags & SVf_ROK)  {
1192                                 sv_catpv(d, "ROK,");
1193         if (SvWEAKREF(sv))      sv_catpv(d, "WEAKREF,");
1194     }
1195     if (flags & SVf_OOK)        sv_catpv(d, "OOK,");
1196     if (flags & SVf_FAKE)       sv_catpv(d, "FAKE,");
1197     if (flags & SVf_READONLY)   sv_catpv(d, "READONLY,");
1198
1199     if (flags & SVf_AMAGIC && type != SVt_PVHV)
1200                                 sv_catpv(d, "OVERLOAD,");
1201     if (flags & SVp_IOK)        sv_catpv(d, "pIOK,");
1202     if (flags & SVp_NOK)        sv_catpv(d, "pNOK,");
1203     if (flags & SVp_POK)        sv_catpv(d, "pPOK,");
1204     if (flags & SVp_SCREAM && type != SVt_PVHV)
1205                                 sv_catpv(d, "SCREAM,");
1206
1207     switch (type) {
1208     case SVt_PVCV:
1209     case SVt_PVFM:
1210         if (CvANON(sv))         sv_catpv(d, "ANON,");
1211         if (CvUNIQUE(sv))       sv_catpv(d, "UNIQUE,");
1212         if (CvCLONE(sv))        sv_catpv(d, "CLONE,");
1213         if (CvCLONED(sv))       sv_catpv(d, "CLONED,");
1214         if (CvCONST(sv))        sv_catpv(d, "CONST,");
1215         if (CvNODEBUG(sv))      sv_catpv(d, "NODEBUG,");
1216         if (SvCOMPILED(sv))     sv_catpv(d, "COMPILED,");
1217         if (CvLVALUE(sv))       sv_catpv(d, "LVALUE,");
1218         if (CvMETHOD(sv))       sv_catpv(d, "METHOD,");
1219         if (CvLOCKED(sv))       sv_catpv(d, "LOCKED,");
1220         if (CvWEAKOUTSIDE(sv))  sv_catpv(d, "WEAKOUTSIDE,");
1221         break;
1222     case SVt_PVHV:
1223         if (HvSHAREKEYS(sv))    sv_catpv(d, "SHAREKEYS,");
1224         if (HvLAZYDEL(sv))      sv_catpv(d, "LAZYDEL,");
1225         if (HvHASKFLAGS(sv))    sv_catpv(d, "HASKFLAGS,");
1226         if (HvREHASH(sv))       sv_catpv(d, "REHASH,");
1227         if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
1228         break;
1229     case SVt_PVGV:
1230         if (GvINTRO(sv))        sv_catpv(d, "INTRO,");
1231         if (GvMULTI(sv))        sv_catpv(d, "MULTI,");
1232         if (GvUNIQUE(sv))       sv_catpv(d, "UNIQUE,");
1233         if (GvASSUMECV(sv))     sv_catpv(d, "ASSUMECV,");
1234         if (GvIN_PAD(sv))       sv_catpv(d, "IN_PAD,");
1235         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1236         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1237         if (GvIMPORTED(sv)) {
1238             sv_catpv(d, "IMPORT");
1239             if (GvIMPORTED(sv) == GVf_IMPORTED)
1240                 sv_catpv(d, "ALL,");
1241             else {
1242                 sv_catpv(d, "(");
1243                 if (GvIMPORTED_SV(sv))  sv_catpv(d, " SV");
1244                 if (GvIMPORTED_AV(sv))  sv_catpv(d, " AV");
1245                 if (GvIMPORTED_HV(sv))  sv_catpv(d, " HV");
1246                 if (GvIMPORTED_CV(sv))  sv_catpv(d, " CV");
1247                 sv_catpv(d, " ),");
1248             }
1249         }
1250         /* FALL THROUGH */
1251     default:
1252     evaled_or_uv:
1253         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1254         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1255         break;
1256     case SVt_PVBM:
1257         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1258         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1259         break;
1260     case SVt_PVMG:
1261         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1262         goto evaled_or_uv;
1263     }
1264     /* SVphv_SHAREKEYS is also 0x20000000 */
1265     if ((type != SVt_PVHV) && SvUTF8(sv))
1266         sv_catpv(d, "UTF8");
1267
1268     if (*(SvEND(d) - 1) == ',') {
1269         SvCUR_set(d, SvCUR(d) - 1);
1270         SvPVX(d)[SvCUR(d)] = '\0';
1271     }
1272     sv_catpv(d, ")");
1273     s = SvPVX_const(d);
1274
1275     Perl_dump_indent(aTHX_ level, file, "SV = ");
1276     if (type < SVt_LAST) {
1277         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1278
1279         if (type ==  SVt_NULL) {
1280             SvREFCNT_dec(d);
1281             return;
1282         }
1283     } else {
1284         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1285         SvREFCNT_dec(d);
1286         return;
1287     }
1288     if (type >= SVt_PVIV || type == SVt_IV) {
1289         if (SvIsUV(sv))
1290             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1291         else
1292             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1293         if (SvOOK(sv))
1294             PerlIO_printf(file, "  (OFFSET)");
1295         PerlIO_putc(file, '\n');
1296     }
1297     if (type >= SVt_PVNV || type == SVt_NV) {
1298         STORE_NUMERIC_LOCAL_SET_STANDARD();
1299         /* %Vg doesn't work? --jhi */
1300 #ifdef USE_LONG_DOUBLE
1301         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1302 #else
1303         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1304 #endif
1305         RESTORE_NUMERIC_LOCAL();
1306     }
1307     if (SvROK(sv)) {
1308         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1309         if (nest < maxnest)
1310             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1311     }
1312     if (type < SVt_PV) {
1313         SvREFCNT_dec(d);
1314         return;
1315     }
1316     if (type <= SVt_PVLV || type == SVt_PVGV) {
1317         if (SvPVX_const(sv)) {
1318             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1319             if (SvOOK(sv))
1320                 PerlIO_printf(file, "( %s . ) ", pv_display(d, (char *)SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim));
1321             PerlIO_printf(file, "%s", pv_display(d, (char *)SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1322             if (SvUTF8(sv)) /* the 8?  \x{....} */
1323                 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ));
1324             PerlIO_printf(file, "\n");
1325             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1326             Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
1327         }
1328         else
1329             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1330     }
1331     if (type >= SVt_PVMG) {
1332         if (SvMAGIC(sv))
1333             do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1334         if (SvSTASH(sv))
1335             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1336     }
1337     switch (type) {
1338     case SVt_PVLV:
1339         Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
1340         Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1341         Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1342         Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1343         if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1344             do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1345                     dumpops, pvlim);
1346         break;
1347     case SVt_PVAV:
1348         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1349         if (AvARRAY(sv) != AvALLOC(sv)) {
1350             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1351             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1352         }
1353         else
1354             PerlIO_putc(file, '\n');
1355         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1356         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1357         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", PTR2UV(AvARYLEN(sv)));
1358         flags = AvFLAGS(sv);
1359         sv_setpvn(d, "", 0);
1360         if (flags & AVf_REAL)   sv_catpv(d, ",REAL");
1361         if (flags & AVf_REIFY)  sv_catpv(d, ",REIFY");
1362         if (flags & AVf_REUSED) sv_catpv(d, ",REUSED");
1363         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1364                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1365         if (nest < maxnest && av_len((AV*)sv) >= 0) {
1366             int count;
1367             for (count = 0; count <=  av_len((AV*)sv) && count < maxnest; count++) {
1368                 SV** elt = av_fetch((AV*)sv,count,0);
1369
1370                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1371                 if (elt)
1372                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1373             }
1374         }
1375         break;
1376     case SVt_PVHV:
1377         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1378         if (HvARRAY(sv) && HvKEYS(sv)) {
1379             /* Show distribution of HEs in the ARRAY */
1380             int freq[200];
1381 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1382             int i;
1383             int max = 0;
1384             U32 pow2 = 2, keys = HvKEYS(sv);
1385             NV theoret, sum = 0;
1386
1387             PerlIO_printf(file, "  (");
1388             Zero(freq, FREQ_MAX + 1, int);
1389             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1390                 HE* h;
1391                 int count = 0;
1392                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1393                     count++;
1394                 if (count > FREQ_MAX)
1395                     count = FREQ_MAX;
1396                 freq[count]++;
1397                 if (max < count)
1398                     max = count;
1399             }
1400             for (i = 0; i <= max; i++) {
1401                 if (freq[i]) {
1402                     PerlIO_printf(file, "%d%s:%d", i,
1403                                   (i == FREQ_MAX) ? "+" : "",
1404                                   freq[i]);
1405                     if (i != max)
1406                         PerlIO_printf(file, ", ");
1407                 }
1408             }
1409             PerlIO_putc(file, ')');
1410             /* The "quality" of a hash is defined as the total number of
1411                comparisons needed to access every element once, relative
1412                to the expected number needed for a random hash.
1413
1414                The total number of comparisons is equal to the sum of
1415                the squares of the number of entries in each bucket.
1416                For a random hash of n keys into k buckets, the expected
1417                value is
1418                                 n + n(n-1)/2k
1419             */
1420
1421             for (i = max; i > 0; i--) { /* Precision: count down. */
1422                 sum += freq[i] * i * i;
1423             }
1424             while ((keys = keys >> 1))
1425                 pow2 = pow2 << 1;
1426             theoret = HvKEYS(sv);
1427             theoret += theoret * (theoret-1)/pow2;
1428             PerlIO_putc(file, '\n');
1429             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1430         }
1431         PerlIO_putc(file, '\n');
1432         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1433         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1434         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1435         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1436         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1437         if (HvPMROOT(sv))
1438             Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(HvPMROOT(sv)));
1439         {
1440             const char * const hvname = HvNAME_get(sv);
1441             if (hvname)
1442                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1443         }
1444         if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1445             HE *he;
1446             HV * const hv = (HV*)sv;
1447             int count = maxnest - nest;
1448
1449             hv_iterinit(hv);
1450             while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1451                    && count--) {
1452                 SV *elt, *keysv;
1453                 const char *keypv;
1454                 STRLEN len;
1455                 const U32 hash = HeHASH(he);
1456
1457                 keysv = hv_iterkeysv(he);
1458                 keypv = SvPV_const(keysv, len);
1459                 elt = hv_iterval(hv, he);
1460                 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, (char *)keypv, len, 0, pvlim));
1461                 if (SvUTF8(keysv))
1462                     PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
1463                 if (HeKREHASH(he))
1464                     PerlIO_printf(file, "[REHASH] ");
1465                 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1466                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1467             }
1468             hv_iterinit(hv);            /* Return to status quo */
1469         }
1470         break;
1471     case SVt_PVCV:
1472         if (SvPOK(sv)) {
1473             STRLEN len;
1474             const char *const proto =  SvPV_const(sv, len);
1475             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1476                              (int) len, proto);
1477         }
1478         /* FALL THROUGH */
1479     case SVt_PVFM:
1480         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1481         if (CvSTART(sv))
1482             Perl_dump_indent(aTHX_ level, file, "  START = 0x%"UVxf" ===> %"IVdf"\n", PTR2UV(CvSTART(sv)), (IV)CvSTART(sv)->op_seq);
1483         Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n", PTR2UV(CvROOT(sv)));
1484         if (CvROOT(sv) && dumpops)
1485             do_op_dump(level+1, file, CvROOT(sv));
1486         Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1487         {
1488             SV *constant = cv_const_sv((CV *)sv);
1489
1490
1491             if (constant) {
1492                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1493                                  " (CONST SV)\n",
1494                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1495                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1496                            pvlim);
1497             } else {
1498                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1499                                  (IV)CvXSUBANY(sv).any_i32);
1500             }
1501         }
1502         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1503         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1504         Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1505 #ifdef USE_5005THREADS
1506         Perl_dump_indent(aTHX_ level, file, "  MUTEXP = 0x%"UVxf"\n", PTR2UV(CvMUTEXP(sv)));
1507         Perl_dump_indent(aTHX_ level, file, "  OWNER = 0x%"UVxf"\n",  PTR2UV(CvOWNER(sv)));
1508 #endif /* USE_5005THREADS */
1509         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1510         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1511         if (type == SVt_PVFM)
1512             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
1513         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1514         if (nest < maxnest) {
1515             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1516         }
1517         {
1518             const CV * const outside = CvOUTSIDE(sv);
1519             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1520                         PTR2UV(outside),
1521                         (!outside ? "null"
1522                          : CvANON(outside) ? "ANON"
1523                          : (outside == PL_main_cv) ? "MAIN"
1524                          : CvUNIQUE(outside) ? "UNIQUE"
1525                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1526         }
1527         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1528             do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1529         break;
1530     case SVt_PVGV:
1531         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
1532         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1533         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
1534         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1535         if (!GvGP(sv))
1536             break;
1537         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1538         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1539         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1540         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
1541         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1542         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1543         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1544         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1545         Perl_dump_indent(aTHX_ level, file, "    GPFLAGS = 0x%"UVxf"\n", (UV)GvGPFLAGS(sv));
1546         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
1547         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
1548         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1549         do_gv_dump (level, file, "    EGV", GvEGV(sv));
1550         break;
1551     case SVt_PVIO:
1552         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1553         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1554         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1555         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
1556         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1557         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1558         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1559         if (IoTOP_NAME(sv))
1560             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1561         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1562             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
1563         else {
1564             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
1565                              PTR2UV(IoTOP_GV(sv)));
1566             do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1567                         dumpops, pvlim);
1568         }
1569         /* Source filters hide things that are not GVs in these three, so let's
1570            be careful out there.  */
1571         if (IoFMT_NAME(sv))
1572             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1573         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1574             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
1575         else {
1576             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
1577                              PTR2UV(IoFMT_GV(sv)));
1578             do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1579                         dumpops, pvlim);
1580         }
1581         if (IoBOTTOM_NAME(sv))
1582             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1583         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1584             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
1585         else {
1586             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
1587                              PTR2UV(IoBOTTOM_GV(sv)));
1588             do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1589                         dumpops, pvlim);
1590         }
1591         Perl_dump_indent(aTHX_ level, file, "  SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv));
1592         if (isPRINT(IoTYPE(sv)))
1593             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
1594         else
1595             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
1596         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1597         break;
1598     }
1599     SvREFCNT_dec(d);
1600 }
1601
1602 void
1603 Perl_sv_dump(pTHX_ SV *sv)
1604 {
1605     do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1606 }
1607
1608 int
1609 Perl_runops_debug(pTHX)
1610 {
1611     if (!PL_op) {
1612         if (ckWARN_d(WARN_DEBUGGING))
1613             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1614         return 0;
1615     }
1616
1617     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1618     do {
1619         PERL_ASYNC_CHECK();
1620         if (PL_debug) {
1621             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1622                 PerlIO_printf(Perl_debug_log,
1623                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1624                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1625                               PTR2UV(*PL_watchaddr));
1626             if (DEBUG_s_TEST_) {
1627                 if (DEBUG_v_TEST_) {
1628                     PerlIO_printf(Perl_debug_log, "\n");
1629                     deb_stack_all();
1630                 }
1631                 else
1632                     debstack();
1633             }
1634
1635
1636             if (DEBUG_t_TEST_) debop(PL_op);
1637             if (DEBUG_P_TEST_) debprof(PL_op);
1638         }
1639     } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1640     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1641
1642     TAINT_NOT;
1643     return 0;
1644 }
1645
1646 I32
1647 Perl_debop(pTHX_ OP *o)
1648 {
1649     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1650         return 0;
1651
1652     Perl_deb(aTHX_ "%s", OP_NAME(o));
1653     switch (o->op_type) {
1654     case OP_CONST:
1655         PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
1656         break;
1657     case OP_GVSV:
1658     case OP_GV:
1659         if (cGVOPo_gv) {
1660             SV * const sv = newSV(0);
1661             gv_fullname3(sv, cGVOPo_gv, NULL);
1662             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1663             SvREFCNT_dec(sv);
1664         }
1665         else
1666             PerlIO_printf(Perl_debug_log, "(NULL)");
1667         break;
1668     case OP_PADSV:
1669     case OP_PADAV:
1670     case OP_PADHV:
1671         {
1672         /* print the lexical's name */
1673         CV * const cv = deb_curcv(cxstack_ix);
1674         SV *sv;
1675         if (cv) {
1676             AV * const padlist = CvPADLIST(cv);
1677             AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
1678             sv = *av_fetch(comppad, o->op_targ, FALSE);
1679         } else
1680             sv = NULL;
1681         if (sv)
1682             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
1683         else
1684             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
1685         }
1686         break;
1687     default:
1688         break;
1689     }
1690     PerlIO_printf(Perl_debug_log, "\n");
1691     return 0;
1692 }
1693
1694 STATIC CV*
1695 S_deb_curcv(pTHX_ I32 ix)
1696 {
1697     const PERL_CONTEXT * const cx = &cxstack[ix];
1698     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
1699         return cx->blk_sub.cv;
1700     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
1701         return PL_compcv;
1702     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
1703         return PL_main_cv;
1704     else if (ix <= 0)
1705         return Nullcv;
1706     else
1707         return deb_curcv(ix - 1);
1708 }
1709
1710 void
1711 Perl_watch(pTHX_ char **addr)
1712 {
1713     PL_watchaddr = addr;
1714     PL_watchok = *addr;
1715     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
1716         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
1717 }
1718
1719 STATIC void
1720 S_debprof(pTHX_ const OP *o)
1721 {
1722     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1723         return;
1724     if (!PL_profiledata)
1725         Newxz(PL_profiledata, MAXO, U32);
1726     ++PL_profiledata[o->op_type];
1727 }
1728
1729 void
1730 Perl_debprofdump(pTHX)
1731 {
1732     unsigned i;
1733     if (!PL_profiledata)
1734         return;
1735     for (i = 0; i < MAXO; i++) {
1736         if (PL_profiledata[i])
1737             PerlIO_printf(Perl_debug_log,
1738                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
1739                                        PL_op_name[i]);
1740     }
1741 }
1742
1743 /*
1744  * Local variables:
1745  * c-indentation-style: bsd
1746  * c-basic-offset: 4
1747  * indent-tabs-mode: t
1748  * End:
1749  *
1750  * ex: set ts=8 sts=4 sw=4 noet:
1751  */