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