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