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