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 (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1496             if (GvIN_PAD(sv))   sv_catpv(d, "IN_PAD,");
1497         }
1498         if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
1499             sv_catpv(d, "IMPORT");
1500             if (GvIMPORTED(sv) == GVf_IMPORTED)
1501                 sv_catpv(d, "ALL,");
1502             else {
1503                 sv_catpv(d, "(");
1504                 if (GvIMPORTED_SV(sv))  sv_catpv(d, " SV");
1505                 if (GvIMPORTED_AV(sv))  sv_catpv(d, " AV");
1506                 if (GvIMPORTED_HV(sv))  sv_catpv(d, " HV");
1507                 if (GvIMPORTED_CV(sv))  sv_catpv(d, " CV");
1508                 sv_catpv(d, " ),");
1509             }
1510         }
1511         if (SvTAIL(sv))         sv_catpv(d, "TAIL,");
1512         if (SvVALID(sv))        sv_catpv(d, "VALID,");
1513         /* FALL THROUGH */
1514     default:
1515     evaled_or_uv:
1516         if (SvEVALED(sv))       sv_catpv(d, "EVALED,");
1517         if (SvIsUV(sv) && !(flags & SVf_ROK))   sv_catpv(d, "IsUV,");
1518         break;
1519     case SVt_PVMG:
1520         if (SvPAD_TYPED(sv))    sv_catpv(d, "TYPED,");
1521         if (SvPAD_OUR(sv))      sv_catpv(d, "OUR,");
1522         /* FALL THROUGH */
1523     case SVt_PVNV:
1524         if (SvPAD_STATE(sv))    sv_catpv(d, "STATE,");
1525         goto evaled_or_uv;
1526     case SVt_PVAV:
1527         break;
1528     }
1529     /* SVphv_SHAREKEYS is also 0x20000000 */
1530     if ((type != SVt_PVHV) && SvUTF8(sv))
1531         sv_catpv(d, "UTF8");
1532
1533     if (*(SvEND(d) - 1) == ',') {
1534         SvCUR_set(d, SvCUR(d) - 1);
1535         SvPVX(d)[SvCUR(d)] = '\0';
1536     }
1537     sv_catpv(d, ")");
1538     s = SvPVX_const(d);
1539
1540 #ifdef DEBUG_LEAKING_SCALARS
1541     Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1542         sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1543         sv->sv_debug_line,
1544         sv->sv_debug_inpad ? "for" : "by",
1545         sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1546         sv->sv_debug_cloned ? " (cloned)" : "");
1547 #endif
1548     Perl_dump_indent(aTHX_ level, file, "SV = ");
1549     if (type < SVt_LAST) {
1550         PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1551
1552         if (type ==  SVt_NULL) {
1553             SvREFCNT_dec(d);
1554             return;
1555         }
1556     } else {
1557         PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
1558         SvREFCNT_dec(d);
1559         return;
1560     }
1561     if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
1562          && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM)
1563         || (type == SVt_IV && !SvROK(sv))) {
1564         if (SvIsUV(sv)
1565 #ifdef PERL_OLD_COPY_ON_WRITE
1566                        || SvIsCOW(sv)
1567 #endif
1568                                      )
1569             Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
1570         else
1571             Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
1572 #ifdef PERL_OLD_COPY_ON_WRITE
1573         if (SvIsCOW_shared_hash(sv))
1574             PerlIO_printf(file, "  (HASH)");
1575         else if (SvIsCOW_normal(sv))
1576             PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1577 #endif
1578         PerlIO_putc(file, '\n');
1579     }
1580     if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1581         Perl_dump_indent(aTHX_ level, file, "  COP_LOW = %"UVuf"\n",
1582                          (UV) COP_SEQ_RANGE_LOW(sv));
1583         Perl_dump_indent(aTHX_ level, file, "  COP_HIGH = %"UVuf"\n",
1584                          (UV) COP_SEQ_RANGE_HIGH(sv));
1585     } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
1586                 && type != SVt_PVCV && type != SVt_PVFM  && type != SVt_REGEXP
1587                 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
1588                || type == SVt_NV) {
1589         STORE_NUMERIC_LOCAL_SET_STANDARD();
1590         /* %Vg doesn't work? --jhi */
1591 #ifdef USE_LONG_DOUBLE
1592         Perl_dump_indent(aTHX_ level, file, "  NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
1593 #else
1594         Perl_dump_indent(aTHX_ level, file, "  NV = %.*g\n", DBL_DIG, SvNVX(sv));
1595 #endif
1596         RESTORE_NUMERIC_LOCAL();
1597     }
1598     if (SvROK(sv)) {
1599         Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
1600         if (nest < maxnest)
1601             do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
1602     }
1603     if (type < SVt_PV) {
1604         SvREFCNT_dec(d);
1605         return;
1606     }
1607     if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
1608         if (SvPVX_const(sv)) {
1609             STRLEN delta;
1610             if (SvOOK(sv)) {
1611                 SvOOK_offset(sv, delta);
1612                 Perl_dump_indent(aTHX_ level, file,"  OFFSET = %"UVuf"\n",
1613                                  (UV) delta);
1614             } else {
1615                 delta = 0;
1616             }
1617             Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
1618             if (SvOOK(sv)) {
1619                 PerlIO_printf(file, "( %s . ) ",
1620                               pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1621                                          pvlim));
1622             }
1623             PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
1624             if (SvUTF8(sv)) /* the 6?  \x{....} */
1625                 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
1626             PerlIO_printf(file, "\n");
1627             Perl_dump_indent(aTHX_ level, file, "  CUR = %"IVdf"\n", (IV)SvCUR(sv));
1628             Perl_dump_indent(aTHX_ level, file, "  LEN = %"IVdf"\n", (IV)SvLEN(sv));
1629         }
1630         else
1631             Perl_dump_indent(aTHX_ level, file, "  PV = 0\n");
1632     }
1633     if (type == SVt_REGEXP) {
1634         /* FIXME dumping
1635             Perl_dump_indent(aTHX_ level, file, "  REGEXP = 0x%"UVxf"\n",
1636                              PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1637         */
1638     }
1639     if (type >= SVt_PVMG) {
1640         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
1641             HV * const ost = SvOURSTASH(sv);
1642             if (ost)
1643                 do_hv_dump(level, file, "  OURSTASH", ost);
1644         } else {
1645             if (SvMAGIC(sv))
1646                 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1647         }
1648         if (SvSTASH(sv))
1649             do_hv_dump(level, file, "  STASH", SvSTASH(sv));
1650     }
1651     switch (type) {
1652     case SVt_PVAV:
1653         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
1654         if (AvARRAY(sv) != AvALLOC(sv)) {
1655             PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1656             Perl_dump_indent(aTHX_ level, file, "  ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
1657         }
1658         else
1659             PerlIO_putc(file, '\n');
1660         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1661         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)AvMAX(sv));
1662         Perl_dump_indent(aTHX_ level, file, "  ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
1663         sv_setpvs(d, "");
1664         if (AvREAL(sv)) sv_catpv(d, ",REAL");
1665         if (AvREIFY(sv))        sv_catpv(d, ",REIFY");
1666         Perl_dump_indent(aTHX_ level, file, "  FLAGS = (%s)\n",
1667                          SvCUR(d) ? SvPVX_const(d) + 1 : "");
1668         if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
1669             int count;
1670             for (count = 0; count <=  av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1671                 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
1672
1673                 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
1674                 if (elt)
1675                     do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1676             }
1677         }
1678         break;
1679     case SVt_PVHV:
1680         Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1681         if (HvARRAY(sv) && HvKEYS(sv)) {
1682             /* Show distribution of HEs in the ARRAY */
1683             int freq[200];
1684 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
1685             int i;
1686             int max = 0;
1687             U32 pow2 = 2, keys = HvKEYS(sv);
1688             NV theoret, sum = 0;
1689
1690             PerlIO_printf(file, "  (");
1691             Zero(freq, FREQ_MAX + 1, int);
1692             for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
1693                 HE* h;
1694                 int count = 0;
1695                 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1696                     count++;
1697                 if (count > FREQ_MAX)
1698                     count = FREQ_MAX;
1699                 freq[count]++;
1700                 if (max < count)
1701                     max = count;
1702             }
1703             for (i = 0; i <= max; i++) {
1704                 if (freq[i]) {
1705                     PerlIO_printf(file, "%d%s:%d", i,
1706                                   (i == FREQ_MAX) ? "+" : "",
1707                                   freq[i]);
1708                     if (i != max)
1709                         PerlIO_printf(file, ", ");
1710                 }
1711             }
1712             PerlIO_putc(file, ')');
1713             /* The "quality" of a hash is defined as the total number of
1714                comparisons needed to access every element once, relative
1715                to the expected number needed for a random hash.
1716
1717                The total number of comparisons is equal to the sum of
1718                the squares of the number of entries in each bucket.
1719                For a random hash of n keys into k buckets, the expected
1720                value is
1721                                 n + n(n-1)/2k
1722             */
1723
1724             for (i = max; i > 0; i--) { /* Precision: count down. */
1725                 sum += freq[i] * i * i;
1726             }
1727             while ((keys = keys >> 1))
1728                 pow2 = pow2 << 1;
1729             theoret = HvKEYS(sv);
1730             theoret += theoret * (theoret-1)/pow2;
1731             PerlIO_putc(file, '\n');
1732             Perl_dump_indent(aTHX_ level, file, "  hash quality = %.1"NVff"%%", theoret/sum*100);
1733         }
1734         PerlIO_putc(file, '\n');
1735         Perl_dump_indent(aTHX_ level, file, "  KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1736         Perl_dump_indent(aTHX_ level, file, "  FILL = %"IVdf"\n", (IV)HvFILL(sv));
1737         Perl_dump_indent(aTHX_ level, file, "  MAX = %"IVdf"\n", (IV)HvMAX(sv));
1738         Perl_dump_indent(aTHX_ level, file, "  RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1739         Perl_dump_indent(aTHX_ level, file, "  EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
1740         {
1741             MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
1742             if (mg && mg->mg_obj) {
1743                 Perl_dump_indent(aTHX_ level, file, "  PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1744             }
1745         }
1746         {
1747             const char * const hvname = HvNAME_get(sv);
1748             if (hvname)
1749                 Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", hvname);
1750         }
1751         if (SvOOK(sv)) {
1752             AV * const backrefs
1753                 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
1754             if (backrefs) {
1755                 Perl_dump_indent(aTHX_ level, file, "  BACKREFS = 0x%"UVxf"\n",
1756                                  PTR2UV(backrefs));
1757                 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
1758                            dumpops, pvlim);
1759             }
1760         }
1761         if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
1762             HE *he;
1763             HV * const hv = MUTABLE_HV(sv);
1764             int count = maxnest - nest;
1765
1766             hv_iterinit(hv);
1767             while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1768                    && count--) {
1769                 STRLEN len;
1770                 const U32 hash = HeHASH(he);
1771                 SV * const keysv = hv_iterkeysv(he);
1772                 const char * const keypv = SvPV_const(keysv, len);
1773                 SV * const elt = hv_iterval(hv, he);
1774
1775                 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1776                 if (SvUTF8(keysv))
1777                     PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
1778                 if (HeKREHASH(he))
1779                     PerlIO_printf(file, "[REHASH] ");
1780                 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
1781                 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1782             }
1783             hv_iterinit(hv);            /* Return to status quo */
1784         }
1785         break;
1786     case SVt_PVCV:
1787         if (SvPOK(sv)) {
1788             STRLEN len;
1789             const char *const proto =  SvPV_const(sv, len);
1790             Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%.*s\"\n",
1791                              (int) len, proto);
1792         }
1793         /* FALL THROUGH */
1794     case SVt_PVFM:
1795         do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
1796         if (!CvISXSUB(sv)) {
1797             if (CvSTART(sv)) {
1798                 Perl_dump_indent(aTHX_ level, file,
1799                                  "  START = 0x%"UVxf" ===> %"IVdf"\n",
1800                                  PTR2UV(CvSTART(sv)),
1801                                  (IV)sequence_num(CvSTART(sv)));
1802             }
1803             Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n",
1804                              PTR2UV(CvROOT(sv)));
1805             if (CvROOT(sv) && dumpops) {
1806                 do_op_dump(level+1, file, CvROOT(sv));
1807             }
1808         } else {
1809             SV * const constant = cv_const_sv((const CV *)sv);
1810
1811             Perl_dump_indent(aTHX_ level, file, "  XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
1812
1813             if (constant) {
1814                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = 0x%"UVxf
1815                                  " (CONST SV)\n",
1816                                  PTR2UV(CvXSUBANY(sv).any_ptr));
1817                 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1818                            pvlim);
1819             } else {
1820                 Perl_dump_indent(aTHX_ level, file, "  XSUBANY = %"IVdf"\n",
1821                                  (IV)CvXSUBANY(sv).any_i32);
1822             }
1823         }
1824         do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
1825         Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
1826         if (type == SVt_PVCV)
1827             Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1828         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1829         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1830         if (type == SVt_PVFM)
1831             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
1832         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1833         if (nest < maxnest) {
1834             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1835         }
1836         {
1837             const CV * const outside = CvOUTSIDE(sv);
1838             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1839                         PTR2UV(outside),
1840                         (!outside ? "null"
1841                          : CvANON(outside) ? "ANON"
1842                          : (outside == PL_main_cv) ? "MAIN"
1843                          : CvUNIQUE(outside) ? "UNIQUE"
1844                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1845         }
1846         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1847             do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
1848         break;
1849     case SVt_PVGV:
1850     case SVt_PVLV:
1851         if (type == SVt_PVLV) {
1852             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
1853             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1854             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1855             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1856             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1857                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1858                     dumpops, pvlim);
1859         }
1860         if (SvVALID(sv)) {
1861             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %u\n", (U8)BmFLAGS(sv));
1862             Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
1863             Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1864             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1865         }
1866         if (!isGV_with_GP(sv))
1867             break;
1868         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
1869         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1870         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
1871         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1872         if (!GvGP(sv))
1873             break;
1874         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1875         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1876         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1877         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
1878         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1879         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1880         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1881         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1882         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
1883         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
1884         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1885         do_gv_dump (level, file, "    EGV", GvEGV(sv));
1886         break;
1887     case SVt_PVIO:
1888         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1889         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1890         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1891         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
1892         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1893         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1894         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1895         if (IoTOP_NAME(sv))
1896             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1897         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1898             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
1899         else {
1900             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
1901                              PTR2UV(IoTOP_GV(sv)));
1902             do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1903                         maxnest, dumpops, pvlim);
1904         }
1905         /* Source filters hide things that are not GVs in these three, so let's
1906            be careful out there.  */
1907         if (IoFMT_NAME(sv))
1908             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1909         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1910             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
1911         else {
1912             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
1913                              PTR2UV(IoFMT_GV(sv)));
1914             do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1915                         maxnest, dumpops, pvlim);
1916         }
1917         if (IoBOTTOM_NAME(sv))
1918             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1919         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1920             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
1921         else {
1922             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
1923                              PTR2UV(IoBOTTOM_GV(sv)));
1924             do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
1925                         maxnest, dumpops, pvlim);
1926         }
1927         if (isPRINT(IoTYPE(sv)))
1928             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
1929         else
1930             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
1931         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1932         break;
1933     }
1934     SvREFCNT_dec(d);
1935 }
1936
1937 void
1938 Perl_sv_dump(pTHX_ SV *sv)
1939 {
1940     dVAR;
1941
1942     PERL_ARGS_ASSERT_SV_DUMP;
1943
1944     if (SvROK(sv))
1945         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1946     else
1947         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1948 }
1949
1950 int
1951 Perl_runops_debug(pTHX)
1952 {
1953     dVAR;
1954     if (!PL_op) {
1955         if (ckWARN_d(WARN_DEBUGGING))
1956             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1957         return 0;
1958     }
1959
1960     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1961     do {
1962         PERL_ASYNC_CHECK();
1963         if (PL_debug) {
1964             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1965                 PerlIO_printf(Perl_debug_log,
1966                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1967                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1968                               PTR2UV(*PL_watchaddr));
1969             if (DEBUG_s_TEST_) {
1970                 if (DEBUG_v_TEST_) {
1971                     PerlIO_printf(Perl_debug_log, "\n");
1972                     deb_stack_all();
1973                 }
1974                 else
1975                     debstack();
1976             }
1977
1978
1979             if (DEBUG_t_TEST_) debop(PL_op);
1980             if (DEBUG_P_TEST_) debprof(PL_op);
1981         }
1982     } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1983     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1984
1985     TAINT_NOT;
1986     return 0;
1987 }
1988
1989 I32
1990 Perl_debop(pTHX_ const OP *o)
1991 {
1992     dVAR;
1993
1994     PERL_ARGS_ASSERT_DEBOP;
1995
1996     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1997         return 0;
1998
1999     Perl_deb(aTHX_ "%s", OP_NAME(o));
2000     switch (o->op_type) {
2001     case OP_CONST:
2002     case OP_HINTSEVAL:
2003         /* With ITHREADS, consts are stored in the pad, and the right pad
2004          * may not be active here, so check.
2005          * Looks like only during compiling the pads are illegal.
2006          */
2007 #ifdef USE_ITHREADS
2008         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2009 #endif
2010             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2011         break;
2012     case OP_GVSV:
2013     case OP_GV:
2014         if (cGVOPo_gv) {
2015             SV * const sv = newSV(0);
2016 #ifdef PERL_MAD
2017             /* FIXME - is this making unwarranted assumptions about the
2018                UTF-8 cleanliness of the dump file handle?  */
2019             SvUTF8_on(sv);
2020 #endif
2021             gv_fullname3(sv, cGVOPo_gv, NULL);
2022             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2023             SvREFCNT_dec(sv);
2024         }
2025         else
2026             PerlIO_printf(Perl_debug_log, "(NULL)");
2027         break;
2028     case OP_PADSV:
2029     case OP_PADAV:
2030     case OP_PADHV:
2031         {
2032         /* print the lexical's name */
2033         CV * const cv = deb_curcv(cxstack_ix);
2034         SV *sv;
2035         if (cv) {
2036             AV * const padlist = CvPADLIST(cv);
2037             AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
2038             sv = *av_fetch(comppad, o->op_targ, FALSE);
2039         } else
2040             sv = NULL;
2041         if (sv)
2042             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2043         else
2044             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2045         }
2046         break;
2047     default:
2048         break;
2049     }
2050     PerlIO_printf(Perl_debug_log, "\n");
2051     return 0;
2052 }
2053
2054 STATIC CV*
2055 S_deb_curcv(pTHX_ const I32 ix)
2056 {
2057     dVAR;
2058     const PERL_CONTEXT * const cx = &cxstack[ix];
2059     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2060         return cx->blk_sub.cv;
2061     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2062         return PL_compcv;
2063     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2064         return PL_main_cv;
2065     else if (ix <= 0)
2066         return NULL;
2067     else
2068         return deb_curcv(ix - 1);
2069 }
2070
2071 void
2072 Perl_watch(pTHX_ char **addr)
2073 {
2074     dVAR;
2075
2076     PERL_ARGS_ASSERT_WATCH;
2077
2078     PL_watchaddr = addr;
2079     PL_watchok = *addr;
2080     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2081         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2082 }
2083
2084 STATIC void
2085 S_debprof(pTHX_ const OP *o)
2086 {
2087     dVAR;
2088
2089     PERL_ARGS_ASSERT_DEBPROF;
2090
2091     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2092         return;
2093     if (!PL_profiledata)
2094         Newxz(PL_profiledata, MAXO, U32);
2095     ++PL_profiledata[o->op_type];
2096 }
2097
2098 void
2099 Perl_debprofdump(pTHX)
2100 {
2101     dVAR;
2102     unsigned i;
2103     if (!PL_profiledata)
2104         return;
2105     for (i = 0; i < MAXO; i++) {
2106         if (PL_profiledata[i])
2107             PerlIO_printf(Perl_debug_log,
2108                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2109                                        PL_op_name[i]);
2110     }
2111 }
2112
2113 #ifdef PERL_MAD
2114 /*
2115  *    XML variants of most of the above routines
2116  */
2117
2118 STATIC void
2119 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2120 {
2121     va_list args;
2122
2123     PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2124
2125     PerlIO_printf(file, "\n    ");
2126     va_start(args, pat);
2127     xmldump_vindent(level, file, pat, &args);
2128     va_end(args);
2129 }
2130
2131
2132 void
2133 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2134 {
2135     va_list args;
2136     PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2137     va_start(args, pat);
2138     xmldump_vindent(level, file, pat, &args);
2139     va_end(args);
2140 }
2141
2142 void
2143 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2144 {
2145     PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2146
2147     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2148     PerlIO_vprintf(file, pat, *args);
2149 }
2150
2151 void
2152 Perl_xmldump_all(pTHX)
2153 {
2154     PerlIO_setlinebuf(PL_xmlfp);
2155     if (PL_main_root)
2156         op_xmldump(PL_main_root);
2157     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2158         PerlIO_close(PL_xmlfp);
2159     PL_xmlfp = 0;
2160 }
2161
2162 void
2163 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2164 {
2165     I32 i;
2166     HE  *entry;
2167
2168     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2169
2170     if (!HvARRAY(stash))
2171         return;
2172     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2173         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2174             GV *gv = MUTABLE_GV(HeVAL(entry));
2175             HV *hv;
2176             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2177                 continue;
2178             if (GvCVu(gv))
2179                 xmldump_sub(gv);
2180             if (GvFORM(gv))
2181                 xmldump_form(gv);
2182             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2183                 && (hv = GvHV(gv)) && hv != PL_defstash)
2184                 xmldump_packsubs(hv);           /* nested package */
2185         }
2186     }
2187 }
2188
2189 void
2190 Perl_xmldump_sub(pTHX_ const GV *gv)
2191 {
2192     SV * const sv = sv_newmortal();
2193
2194     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2195
2196     gv_fullname3(sv, gv, NULL);
2197     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2198     if (CvXSUB(GvCV(gv)))
2199         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2200             PTR2UV(CvXSUB(GvCV(gv))),
2201             (int)CvXSUBANY(GvCV(gv)).any_i32);
2202     else if (CvROOT(GvCV(gv)))
2203         op_xmldump(CvROOT(GvCV(gv)));
2204     else
2205         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2206 }
2207
2208 void
2209 Perl_xmldump_form(pTHX_ const GV *gv)
2210 {
2211     SV * const sv = sv_newmortal();
2212
2213     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2214
2215     gv_fullname3(sv, gv, NULL);
2216     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2217     if (CvROOT(GvFORM(gv)))
2218         op_xmldump(CvROOT(GvFORM(gv)));
2219     else
2220         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2221 }
2222
2223 void
2224 Perl_xmldump_eval(pTHX)
2225 {
2226     op_xmldump(PL_eval_root);
2227 }
2228
2229 char *
2230 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2231 {
2232     PERL_ARGS_ASSERT_SV_CATXMLSV;
2233     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2234 }
2235
2236 char *
2237 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2238 {
2239     unsigned int c;
2240     const char * const e = pv + len;
2241     const char * const start = pv;
2242     STRLEN dsvcur;
2243     STRLEN cl;
2244
2245     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2246
2247     sv_catpvs(dsv,"");
2248     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2249
2250   retry:
2251     while (pv < e) {
2252         if (utf8) {
2253             c = utf8_to_uvchr((U8*)pv, &cl);
2254             if (cl == 0) {
2255                 SvCUR(dsv) = dsvcur;
2256                 pv = start;
2257                 utf8 = 0;
2258                 goto retry;
2259             }
2260         }
2261         else
2262             c = (*pv & 255);
2263
2264         switch (c) {
2265         case 0x00:
2266         case 0x01:
2267         case 0x02:
2268         case 0x03:
2269         case 0x04:
2270         case 0x05:
2271         case 0x06:
2272         case 0x07:
2273         case 0x08:
2274         case 0x0b:
2275         case 0x0c:
2276         case 0x0e:
2277         case 0x0f:
2278         case 0x10:
2279         case 0x11:
2280         case 0x12:
2281         case 0x13:
2282         case 0x14:
2283         case 0x15:
2284         case 0x16:
2285         case 0x17:
2286         case 0x18:
2287         case 0x19:
2288         case 0x1a:
2289         case 0x1b:
2290         case 0x1c:
2291         case 0x1d:
2292         case 0x1e:
2293         case 0x1f:
2294         case 0x7f:
2295         case 0x80:
2296         case 0x81:
2297         case 0x82:
2298         case 0x83:
2299         case 0x84:
2300         case 0x86:
2301         case 0x87:
2302         case 0x88:
2303         case 0x89:
2304         case 0x90:
2305         case 0x91:
2306         case 0x92:
2307         case 0x93:
2308         case 0x94:
2309         case 0x95:
2310         case 0x96:
2311         case 0x97:
2312         case 0x98:
2313         case 0x99:
2314         case 0x9a:
2315         case 0x9b:
2316         case 0x9c:
2317         case 0x9d:
2318         case 0x9e:
2319         case 0x9f:
2320             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2321             break;
2322         case '<':
2323             sv_catpvs(dsv, "&lt;");
2324             break;
2325         case '>':
2326             sv_catpvs(dsv, "&gt;");
2327             break;
2328         case '&':
2329             sv_catpvs(dsv, "&amp;");
2330             break;
2331         case '"':
2332             sv_catpvs(dsv, "&#34;");
2333             break;
2334         default:
2335             if (c < 0xD800) {
2336                 if (c < 32 || c > 127) {
2337                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2338                 }
2339                 else {
2340                     const char string = (char) c;
2341                     sv_catpvn(dsv, &string, 1);
2342                 }
2343                 break;
2344             }
2345             if ((c >= 0xD800 && c <= 0xDB7F) ||
2346                 (c >= 0xDC00 && c <= 0xDFFF) ||
2347                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2348                  c > 0x10ffff)
2349                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2350             else
2351                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2352         }
2353
2354         if (utf8)
2355             pv += UTF8SKIP(pv);
2356         else
2357             pv++;
2358     }
2359
2360     return SvPVX(dsv);
2361 }
2362
2363 char *
2364 Perl_sv_xmlpeek(pTHX_ SV *sv)
2365 {
2366     SV * const t = sv_newmortal();
2367     STRLEN n_a;
2368     int unref = 0;
2369
2370     PERL_ARGS_ASSERT_SV_XMLPEEK;
2371
2372     sv_utf8_upgrade(t);
2373     sv_setpvs(t, "");
2374     /* retry: */
2375     if (!sv) {
2376         sv_catpv(t, "VOID=\"\"");
2377         goto finish;
2378     }
2379     else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
2380         sv_catpv(t, "WILD=\"\"");
2381         goto finish;
2382     }
2383     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2384         if (sv == &PL_sv_undef) {
2385             sv_catpv(t, "SV_UNDEF=\"1\"");
2386             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2387                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2388                 SvREADONLY(sv))
2389                 goto finish;
2390         }
2391         else if (sv == &PL_sv_no) {
2392             sv_catpv(t, "SV_NO=\"1\"");
2393             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2394                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2395                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2396                                   SVp_POK|SVp_NOK)) &&
2397                 SvCUR(sv) == 0 &&
2398                 SvNVX(sv) == 0.0)
2399                 goto finish;
2400         }
2401         else if (sv == &PL_sv_yes) {
2402             sv_catpv(t, "SV_YES=\"1\"");
2403             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2404                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2405                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2406                                   SVp_POK|SVp_NOK)) &&
2407                 SvCUR(sv) == 1 &&
2408                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2409                 SvNVX(sv) == 1.0)
2410                 goto finish;
2411         }
2412         else {
2413             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2414             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2415                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2416                 SvREADONLY(sv))
2417                 goto finish;
2418         }
2419         sv_catpv(t, " XXX=\"\" ");
2420     }
2421     else if (SvREFCNT(sv) == 0) {
2422         sv_catpv(t, " refcnt=\"0\"");
2423         unref++;
2424     }
2425     else if (DEBUG_R_TEST_) {
2426         int is_tmp = 0;
2427         I32 ix;
2428         /* is this SV on the tmps stack? */
2429         for (ix=PL_tmps_ix; ix>=0; ix--) {
2430             if (PL_tmps_stack[ix] == sv) {
2431                 is_tmp = 1;
2432                 break;
2433             }
2434         }
2435         if (SvREFCNT(sv) > 1)
2436             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2437                     is_tmp ? "T" : "");
2438         else if (is_tmp)
2439             sv_catpv(t, " DRT=\"<T>\"");
2440     }
2441
2442     if (SvROK(sv)) {
2443         sv_catpv(t, " ROK=\"\"");
2444     }
2445     switch (SvTYPE(sv)) {
2446     default:
2447         sv_catpv(t, " FREED=\"1\"");
2448         goto finish;
2449
2450     case SVt_NULL:
2451         sv_catpv(t, " UNDEF=\"1\"");
2452         goto finish;
2453     case SVt_IV:
2454         sv_catpv(t, " IV=\"");
2455         break;
2456     case SVt_NV:
2457         sv_catpv(t, " NV=\"");
2458         break;
2459     case SVt_PV:
2460         sv_catpv(t, " PV=\"");
2461         break;
2462     case SVt_PVIV:
2463         sv_catpv(t, " PVIV=\"");
2464         break;
2465     case SVt_PVNV:
2466         sv_catpv(t, " PVNV=\"");
2467         break;
2468     case SVt_PVMG:
2469         sv_catpv(t, " PVMG=\"");
2470         break;
2471     case SVt_PVLV:
2472         sv_catpv(t, " PVLV=\"");
2473         break;
2474     case SVt_PVAV:
2475         sv_catpv(t, " AV=\"");
2476         break;
2477     case SVt_PVHV:
2478         sv_catpv(t, " HV=\"");
2479         break;
2480     case SVt_PVCV:
2481         if (CvGV(sv))
2482             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2483         else
2484             sv_catpv(t, " CV=\"()\"");
2485         goto finish;
2486     case SVt_PVGV:
2487         sv_catpv(t, " GV=\"");
2488         break;
2489     case SVt_BIND:
2490         sv_catpv(t, " BIND=\"");
2491         break;
2492     case SVt_REGEXP:
2493         sv_catpv(t, " ORANGE=\"");
2494         break;
2495     case SVt_PVFM:
2496         sv_catpv(t, " FM=\"");
2497         break;
2498     case SVt_PVIO:
2499         sv_catpv(t, " IO=\"");
2500         break;
2501     }
2502
2503     if (SvPOKp(sv)) {
2504         if (SvPVX(sv)) {
2505             sv_catxmlsv(t, sv);
2506         }
2507     }
2508     else if (SvNOKp(sv)) {
2509         STORE_NUMERIC_LOCAL_SET_STANDARD();
2510         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2511         RESTORE_NUMERIC_LOCAL();
2512     }
2513     else if (SvIOKp(sv)) {
2514         if (SvIsUV(sv))
2515             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2516         else
2517             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2518     }
2519     else
2520         sv_catpv(t, "");
2521     sv_catpv(t, "\"");
2522
2523   finish:
2524     while (unref--)
2525         sv_catpv(t, ")");
2526     return SvPV(t, n_a);
2527 }
2528
2529 void
2530 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2531 {
2532     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2533
2534     if (!pm) {
2535         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2536         return;
2537     }
2538     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2539     level++;
2540     if (PM_GETRE(pm)) {
2541         REGEXP *const r = PM_GETRE(pm);
2542         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2543         sv_catxmlsv(tmpsv, MUTABLE_SV(r));
2544         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2545              SvPVX(tmpsv));
2546         SvREFCNT_dec(tmpsv);
2547         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2548              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2549     }
2550     else
2551         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2552     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2553         SV * const tmpsv = pm_description(pm);
2554         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2555         SvREFCNT_dec(tmpsv);
2556     }
2557
2558     level--;
2559     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2560         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2561         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2562         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2563         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2564         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2565     }
2566     else
2567         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2568 }
2569
2570 void
2571 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2572 {
2573     do_pmop_xmldump(0, PL_xmlfp, pm);
2574 }
2575
2576 void
2577 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2578 {
2579     UV      seq;
2580     int     contents = 0;
2581
2582     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2583
2584     if (!o)
2585         return;
2586     sequence(o);
2587     seq = sequence_num(o);
2588     Perl_xmldump_indent(aTHX_ level, file,
2589         "<op_%s seq=\"%"UVuf" -> ",
2590              OP_NAME(o),
2591                       seq);
2592     level++;
2593     if (o->op_next)
2594         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2595                       sequence_num(o->op_next));
2596     else
2597         PerlIO_printf(file, "DONE\"");
2598
2599     if (o->op_targ) {
2600         if (o->op_type == OP_NULL)
2601         {
2602             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2603             if (o->op_targ == OP_NEXTSTATE)
2604             {
2605                 if (CopLINE(cCOPo))
2606                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2607                                      (UV)CopLINE(cCOPo));
2608                 if (CopSTASHPV(cCOPo))
2609                     PerlIO_printf(file, " package=\"%s\"",
2610                                      CopSTASHPV(cCOPo));
2611                 if (CopLABEL(cCOPo))
2612                     PerlIO_printf(file, " label=\"%s\"",
2613                                      CopLABEL(cCOPo));
2614             }
2615         }
2616         else
2617             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2618     }
2619 #ifdef DUMPADDR
2620     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2621 #endif
2622     if (o->op_flags) {
2623         SV * const tmpsv = newSVpvs("");
2624         switch (o->op_flags & OPf_WANT) {
2625         case OPf_WANT_VOID:
2626             sv_catpv(tmpsv, ",VOID");
2627             break;
2628         case OPf_WANT_SCALAR:
2629             sv_catpv(tmpsv, ",SCALAR");
2630             break;
2631         case OPf_WANT_LIST:
2632             sv_catpv(tmpsv, ",LIST");
2633             break;
2634         default:
2635             sv_catpv(tmpsv, ",UNKNOWN");
2636             break;
2637         }
2638         if (o->op_flags & OPf_KIDS)
2639             sv_catpv(tmpsv, ",KIDS");
2640         if (o->op_flags & OPf_PARENS)
2641             sv_catpv(tmpsv, ",PARENS");
2642         if (o->op_flags & OPf_STACKED)
2643             sv_catpv(tmpsv, ",STACKED");
2644         if (o->op_flags & OPf_REF)
2645             sv_catpv(tmpsv, ",REF");
2646         if (o->op_flags & OPf_MOD)
2647             sv_catpv(tmpsv, ",MOD");
2648         if (o->op_flags & OPf_SPECIAL)
2649             sv_catpv(tmpsv, ",SPECIAL");
2650         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2651         SvREFCNT_dec(tmpsv);
2652     }
2653     if (o->op_private) {
2654         SV * const tmpsv = newSVpvs("");
2655         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2656             if (o->op_private & OPpTARGET_MY)
2657                 sv_catpv(tmpsv, ",TARGET_MY");
2658         }
2659         else if (o->op_type == OP_LEAVESUB ||
2660                  o->op_type == OP_LEAVE ||
2661                  o->op_type == OP_LEAVESUBLV ||
2662                  o->op_type == OP_LEAVEWRITE) {
2663             if (o->op_private & OPpREFCOUNTED)
2664                 sv_catpv(tmpsv, ",REFCOUNTED");
2665         }
2666         else if (o->op_type == OP_AASSIGN) {
2667             if (o->op_private & OPpASSIGN_COMMON)
2668                 sv_catpv(tmpsv, ",COMMON");
2669         }
2670         else if (o->op_type == OP_SASSIGN) {
2671             if (o->op_private & OPpASSIGN_BACKWARDS)
2672                 sv_catpv(tmpsv, ",BACKWARDS");
2673         }
2674         else if (o->op_type == OP_TRANS) {
2675             if (o->op_private & OPpTRANS_SQUASH)
2676                 sv_catpv(tmpsv, ",SQUASH");
2677             if (o->op_private & OPpTRANS_DELETE)
2678                 sv_catpv(tmpsv, ",DELETE");
2679             if (o->op_private & OPpTRANS_COMPLEMENT)
2680                 sv_catpv(tmpsv, ",COMPLEMENT");
2681             if (o->op_private & OPpTRANS_IDENTICAL)
2682                 sv_catpv(tmpsv, ",IDENTICAL");
2683             if (o->op_private & OPpTRANS_GROWS)
2684                 sv_catpv(tmpsv, ",GROWS");
2685         }
2686         else if (o->op_type == OP_REPEAT) {
2687             if (o->op_private & OPpREPEAT_DOLIST)
2688                 sv_catpv(tmpsv, ",DOLIST");
2689         }
2690         else if (o->op_type == OP_ENTERSUB ||
2691                  o->op_type == OP_RV2SV ||
2692                  o->op_type == OP_GVSV ||
2693                  o->op_type == OP_RV2AV ||
2694                  o->op_type == OP_RV2HV ||
2695                  o->op_type == OP_RV2GV ||
2696                  o->op_type == OP_AELEM ||
2697                  o->op_type == OP_HELEM )
2698         {
2699             if (o->op_type == OP_ENTERSUB) {
2700                 if (o->op_private & OPpENTERSUB_AMPER)
2701                     sv_catpv(tmpsv, ",AMPER");
2702                 if (o->op_private & OPpENTERSUB_DB)
2703                     sv_catpv(tmpsv, ",DB");
2704                 if (o->op_private & OPpENTERSUB_HASTARG)
2705                     sv_catpv(tmpsv, ",HASTARG");
2706                 if (o->op_private & OPpENTERSUB_NOPAREN)
2707                     sv_catpv(tmpsv, ",NOPAREN");
2708                 if (o->op_private & OPpENTERSUB_INARGS)
2709                     sv_catpv(tmpsv, ",INARGS");
2710                 if (o->op_private & OPpENTERSUB_NOMOD)
2711                     sv_catpv(tmpsv, ",NOMOD");
2712             }
2713             else {
2714                 switch (o->op_private & OPpDEREF) {
2715             case OPpDEREF_SV:
2716                 sv_catpv(tmpsv, ",SV");
2717                 break;
2718             case OPpDEREF_AV:
2719                 sv_catpv(tmpsv, ",AV");
2720                 break;
2721             case OPpDEREF_HV:
2722                 sv_catpv(tmpsv, ",HV");
2723                 break;
2724             }
2725                 if (o->op_private & OPpMAYBE_LVSUB)
2726                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2727             }
2728             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2729                 if (o->op_private & OPpLVAL_DEFER)
2730                     sv_catpv(tmpsv, ",LVAL_DEFER");
2731             }
2732             else {
2733                 if (o->op_private & HINT_STRICT_REFS)
2734                     sv_catpv(tmpsv, ",STRICT_REFS");
2735                 if (o->op_private & OPpOUR_INTRO)
2736                     sv_catpv(tmpsv, ",OUR_INTRO");
2737             }
2738         }
2739         else if (o->op_type == OP_CONST) {
2740             if (o->op_private & OPpCONST_BARE)
2741                 sv_catpv(tmpsv, ",BARE");
2742             if (o->op_private & OPpCONST_STRICT)
2743                 sv_catpv(tmpsv, ",STRICT");
2744             if (o->op_private & OPpCONST_ARYBASE)
2745                 sv_catpv(tmpsv, ",ARYBASE");
2746             if (o->op_private & OPpCONST_WARNING)
2747                 sv_catpv(tmpsv, ",WARNING");
2748             if (o->op_private & OPpCONST_ENTERED)
2749                 sv_catpv(tmpsv, ",ENTERED");
2750         }
2751         else if (o->op_type == OP_FLIP) {
2752             if (o->op_private & OPpFLIP_LINENUM)
2753                 sv_catpv(tmpsv, ",LINENUM");
2754         }
2755         else if (o->op_type == OP_FLOP) {
2756             if (o->op_private & OPpFLIP_LINENUM)
2757                 sv_catpv(tmpsv, ",LINENUM");
2758         }
2759         else if (o->op_type == OP_RV2CV) {
2760             if (o->op_private & OPpLVAL_INTRO)
2761                 sv_catpv(tmpsv, ",INTRO");
2762         }
2763         else if (o->op_type == OP_GV) {
2764             if (o->op_private & OPpEARLY_CV)
2765                 sv_catpv(tmpsv, ",EARLY_CV");
2766         }
2767         else if (o->op_type == OP_LIST) {
2768             if (o->op_private & OPpLIST_GUESSED)
2769                 sv_catpv(tmpsv, ",GUESSED");
2770         }
2771         else if (o->op_type == OP_DELETE) {
2772             if (o->op_private & OPpSLICE)
2773                 sv_catpv(tmpsv, ",SLICE");
2774         }
2775         else if (o->op_type == OP_EXISTS) {
2776             if (o->op_private & OPpEXISTS_SUB)
2777                 sv_catpv(tmpsv, ",EXISTS_SUB");
2778         }
2779         else if (o->op_type == OP_SORT) {
2780             if (o->op_private & OPpSORT_NUMERIC)
2781                 sv_catpv(tmpsv, ",NUMERIC");
2782             if (o->op_private & OPpSORT_INTEGER)
2783                 sv_catpv(tmpsv, ",INTEGER");
2784             if (o->op_private & OPpSORT_REVERSE)
2785                 sv_catpv(tmpsv, ",REVERSE");
2786         }
2787         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2788             if (o->op_private & OPpOPEN_IN_RAW)
2789                 sv_catpv(tmpsv, ",IN_RAW");
2790             if (o->op_private & OPpOPEN_IN_CRLF)
2791                 sv_catpv(tmpsv, ",IN_CRLF");
2792             if (o->op_private & OPpOPEN_OUT_RAW)
2793                 sv_catpv(tmpsv, ",OUT_RAW");
2794             if (o->op_private & OPpOPEN_OUT_CRLF)
2795                 sv_catpv(tmpsv, ",OUT_CRLF");
2796         }
2797         else if (o->op_type == OP_EXIT) {
2798             if (o->op_private & OPpEXIT_VMSISH)
2799                 sv_catpv(tmpsv, ",EXIT_VMSISH");
2800             if (o->op_private & OPpHUSH_VMSISH)
2801                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2802         }
2803         else if (o->op_type == OP_DIE) {
2804             if (o->op_private & OPpHUSH_VMSISH)
2805                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2806         }
2807         else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2808             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2809                 sv_catpv(tmpsv, ",FT_ACCESS");
2810             if (o->op_private & OPpFT_STACKED)
2811                 sv_catpv(tmpsv, ",FT_STACKED");
2812         }
2813         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2814             sv_catpv(tmpsv, ",INTRO");
2815         if (SvCUR(tmpsv))
2816             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2817         SvREFCNT_dec(tmpsv);
2818     }
2819
2820     switch (o->op_type) {
2821     case OP_AELEMFAST:
2822         if (o->op_flags & OPf_SPECIAL) {
2823             break;
2824         }
2825     case OP_GVSV:
2826     case OP_GV:
2827 #ifdef USE_ITHREADS
2828         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2829 #else
2830         if (cSVOPo->op_sv) {
2831             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2832             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2833             char *s;
2834             STRLEN len;
2835             ENTER;
2836             SAVEFREESV(tmpsv1);
2837             SAVEFREESV(tmpsv2);
2838             gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
2839             s = SvPV(tmpsv1,len);
2840             sv_catxmlpvn(tmpsv2, s, len, 1);
2841             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2842             LEAVE;
2843         }
2844         else
2845             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2846 #endif
2847         break;
2848     case OP_CONST:
2849     case OP_HINTSEVAL:
2850     case OP_METHOD_NAMED:
2851 #ifndef USE_ITHREADS
2852         /* with ITHREADS, consts are stored in the pad, and the right pad
2853          * may not be active here, so skip */
2854         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2855 #endif
2856         break;
2857     case OP_ANONCODE:
2858         if (!contents) {
2859             contents = 1;
2860             PerlIO_printf(file, ">\n");
2861         }
2862         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2863         break;
2864     case OP_NEXTSTATE:
2865     case OP_DBSTATE:
2866         if (CopLINE(cCOPo))
2867             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2868                              (UV)CopLINE(cCOPo));
2869         if (CopSTASHPV(cCOPo))
2870             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2871                              CopSTASHPV(cCOPo));
2872         if (CopLABEL(cCOPo))
2873             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2874                              CopLABEL(cCOPo));
2875         break;
2876     case OP_ENTERLOOP:
2877         S_xmldump_attr(aTHX_ level, file, "redo=\"");
2878         if (cLOOPo->op_redoop)
2879             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2880         else
2881             PerlIO_printf(file, "DONE\"");
2882         S_xmldump_attr(aTHX_ level, file, "next=\"");
2883         if (cLOOPo->op_nextop)
2884             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2885         else
2886             PerlIO_printf(file, "DONE\"");
2887         S_xmldump_attr(aTHX_ level, file, "last=\"");
2888         if (cLOOPo->op_lastop)
2889             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2890         else
2891             PerlIO_printf(file, "DONE\"");
2892         break;
2893     case OP_COND_EXPR:
2894     case OP_RANGE:
2895     case OP_MAPWHILE:
2896     case OP_GREPWHILE:
2897     case OP_OR:
2898     case OP_AND:
2899         S_xmldump_attr(aTHX_ level, file, "other=\"");
2900         if (cLOGOPo->op_other)
2901             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2902         else
2903             PerlIO_printf(file, "DONE\"");
2904         break;
2905     case OP_LEAVE:
2906     case OP_LEAVEEVAL:
2907     case OP_LEAVESUB:
2908     case OP_LEAVESUBLV:
2909     case OP_LEAVEWRITE:
2910     case OP_SCOPE:
2911         if (o->op_private & OPpREFCOUNTED)
2912             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2913         break;
2914     default:
2915         break;
2916     }
2917
2918     if (PL_madskills && o->op_madprop) {
2919         char prevkey = '\0';
2920         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2921         const MADPROP* mp = o->op_madprop;
2922
2923         if (!contents) {
2924             contents = 1;
2925             PerlIO_printf(file, ">\n");
2926         }
2927         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2928         level++;
2929         while (mp) {
2930             char tmp = mp->mad_key;
2931             sv_setpvs(tmpsv,"\"");
2932             if (tmp)
2933                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2934             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2935                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2936             else
2937                 prevkey = tmp;
2938             sv_catpv(tmpsv, "\"");
2939             switch (mp->mad_type) {
2940             case MAD_NULL:
2941                 sv_catpv(tmpsv, "NULL");
2942                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2943                 break;
2944             case MAD_PV:
2945                 sv_catpv(tmpsv, " val=\"");
2946                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2947                 sv_catpv(tmpsv, "\"");
2948                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2949                 break;
2950             case MAD_SV:
2951                 sv_catpv(tmpsv, " val=\"");
2952                 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
2953                 sv_catpv(tmpsv, "\"");
2954                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2955                 break;
2956             case MAD_OP:
2957                 if ((OP*)mp->mad_val) {
2958                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2959                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2960                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2961                 }
2962                 break;
2963             default:
2964                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2965                 break;
2966             }
2967             mp = mp->mad_next;
2968         }
2969         level--;
2970         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2971
2972         SvREFCNT_dec(tmpsv);
2973     }
2974
2975     switch (o->op_type) {
2976     case OP_PUSHRE:
2977     case OP_MATCH:
2978     case OP_QR:
2979     case OP_SUBST:
2980         if (!contents) {
2981             contents = 1;
2982             PerlIO_printf(file, ">\n");
2983         }
2984         do_pmop_xmldump(level, file, cPMOPo);
2985         break;
2986     default:
2987         break;
2988     }
2989
2990     if (o->op_flags & OPf_KIDS) {
2991         OP *kid;
2992         if (!contents) {
2993             contents = 1;
2994             PerlIO_printf(file, ">\n");
2995         }
2996         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2997             do_op_xmldump(level, file, kid);
2998     }
2999
3000     if (contents)
3001         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3002     else
3003         PerlIO_printf(file, " />\n");
3004 }
3005
3006 void
3007 Perl_op_xmldump(pTHX_ const OP *o)
3008 {
3009     PERL_ARGS_ASSERT_OP_XMLDUMP;
3010
3011     do_op_xmldump(0, PL_xmlfp, o);
3012 }
3013 #endif
3014
3015 /*
3016  * Local variables:
3017  * c-indentation-style: bsd
3018  * c-basic-offset: 4
3019  * indent-tabs-mode: t
3020  * End:
3021  *
3022  * ex: set ts=8 sts=4 sw=4 noet:
3023  */