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