dump.c

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