dump.c

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