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