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         if (type == SVt_PVCV)
1830             Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
1831         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
1832         Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
1833         if (type == SVt_PVFM)
1834             Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
1835         Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1836         if (nest < maxnest) {
1837             do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1838         }
1839         {
1840             const CV * const outside = CvOUTSIDE(sv);
1841             Perl_dump_indent(aTHX_ level, file, "  OUTSIDE = 0x%"UVxf" (%s)\n",
1842                         PTR2UV(outside),
1843                         (!outside ? "null"
1844                          : CvANON(outside) ? "ANON"
1845                          : (outside == PL_main_cv) ? "MAIN"
1846                          : CvUNIQUE(outside) ? "UNIQUE"
1847                          : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
1848         }
1849         if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
1850             do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
1851         break;
1852     case SVt_PVGV:
1853     case SVt_PVLV:
1854         if (type == SVt_PVLV) {
1855             Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
1856             Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1857             Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1858             Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1859             if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1860                 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1861                     dumpops, pvlim);
1862         }
1863         if (SvVALID(sv)) {
1864             Perl_dump_indent(aTHX_ level, file, "  FLAGS = %u\n", (U8)BmFLAGS(sv));
1865             Perl_dump_indent(aTHX_ level, file, "  RARE = %u\n", (U8)BmRARE(sv));
1866             Perl_dump_indent(aTHX_ level, file, "  PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1867             Perl_dump_indent(aTHX_ level, file, "  USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1868         }
1869         if (!isGV_with_GP(sv))
1870             break;
1871         Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
1872         Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
1873         do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
1874         Perl_dump_indent(aTHX_ level, file, "  GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
1875         if (!GvGP(sv))
1876             break;
1877         Perl_dump_indent(aTHX_ level, file, "    SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1878         Perl_dump_indent(aTHX_ level, file, "    REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1879         Perl_dump_indent(aTHX_ level, file, "    IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1880         Perl_dump_indent(aTHX_ level, file, "    FORM = 0x%"UVxf"  \n", PTR2UV(GvFORM(sv)));
1881         Perl_dump_indent(aTHX_ level, file, "    AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1882         Perl_dump_indent(aTHX_ level, file, "    HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1883         Perl_dump_indent(aTHX_ level, file, "    CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1884         Perl_dump_indent(aTHX_ level, file, "    CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
1885         Perl_dump_indent(aTHX_ level, file, "    LINE = %"IVdf"\n", (IV)GvLINE(sv));
1886         Perl_dump_indent(aTHX_ level, file, "    FILE = \"%s\"\n", GvFILE(sv));
1887         Perl_dump_indent(aTHX_ level, file, "    FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
1888         do_gv_dump (level, file, "    EGV", GvEGV(sv));
1889         break;
1890     case SVt_PVIO:
1891         Perl_dump_indent(aTHX_ level, file, "  IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1892         Perl_dump_indent(aTHX_ level, file, "  OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1893         Perl_dump_indent(aTHX_ level, file, "  DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1894         Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)IoLINES(sv));
1895         Perl_dump_indent(aTHX_ level, file, "  PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1896         Perl_dump_indent(aTHX_ level, file, "  PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1897         Perl_dump_indent(aTHX_ level, file, "  LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
1898         if (IoTOP_NAME(sv))
1899             Perl_dump_indent(aTHX_ level, file, "  TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
1900         if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1901             do_gv_dump (level, file, "  TOP_GV", IoTOP_GV(sv));
1902         else {
1903             Perl_dump_indent(aTHX_ level, file, "  TOP_GV = 0x%"UVxf"\n",
1904                              PTR2UV(IoTOP_GV(sv)));
1905             do_sv_dump (level+1, file, (SV *) IoTOP_GV(sv), nest+1, maxnest,
1906                         dumpops, pvlim);
1907         }
1908         /* Source filters hide things that are not GVs in these three, so let's
1909            be careful out there.  */
1910         if (IoFMT_NAME(sv))
1911             Perl_dump_indent(aTHX_ level, file, "  FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
1912         if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1913             do_gv_dump (level, file, "  FMT_GV", IoFMT_GV(sv));
1914         else {
1915             Perl_dump_indent(aTHX_ level, file, "  FMT_GV = 0x%"UVxf"\n",
1916                              PTR2UV(IoFMT_GV(sv)));
1917             do_sv_dump (level+1, file, (SV *) IoFMT_GV(sv), nest+1, maxnest,
1918                         dumpops, pvlim);
1919         }
1920         if (IoBOTTOM_NAME(sv))
1921             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
1922         if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1923             do_gv_dump (level, file, "  BOTTOM_GV", IoBOTTOM_GV(sv));
1924         else {
1925             Perl_dump_indent(aTHX_ level, file, "  BOTTOM_GV = 0x%"UVxf"\n",
1926                              PTR2UV(IoBOTTOM_GV(sv)));
1927             do_sv_dump (level+1, file, (SV *) IoBOTTOM_GV(sv), nest+1, maxnest,
1928                         dumpops, pvlim);
1929         }
1930         if (isPRINT(IoTYPE(sv)))
1931             Perl_dump_indent(aTHX_ level, file, "  TYPE = '%c'\n", IoTYPE(sv));
1932         else
1933             Perl_dump_indent(aTHX_ level, file, "  TYPE = '\\%o'\n", IoTYPE(sv));
1934         Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
1935         break;
1936     }
1937     SvREFCNT_dec(d);
1938 }
1939
1940 void
1941 Perl_sv_dump(pTHX_ SV *sv)
1942 {
1943     dVAR;
1944
1945     PERL_ARGS_ASSERT_SV_DUMP;
1946
1947     if (SvROK(sv))
1948         do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1949     else
1950         do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
1951 }
1952
1953 int
1954 Perl_runops_debug(pTHX)
1955 {
1956     dVAR;
1957     if (!PL_op) {
1958         if (ckWARN_d(WARN_DEBUGGING))
1959             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
1960         return 0;
1961     }
1962
1963     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
1964     do {
1965         PERL_ASYNC_CHECK();
1966         if (PL_debug) {
1967             if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
1968                 PerlIO_printf(Perl_debug_log,
1969                               "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1970                               PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1971                               PTR2UV(*PL_watchaddr));
1972             if (DEBUG_s_TEST_) {
1973                 if (DEBUG_v_TEST_) {
1974                     PerlIO_printf(Perl_debug_log, "\n");
1975                     deb_stack_all();
1976                 }
1977                 else
1978                     debstack();
1979             }
1980
1981
1982             if (DEBUG_t_TEST_) debop(PL_op);
1983             if (DEBUG_P_TEST_) debprof(PL_op);
1984         }
1985     } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
1986     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
1987
1988     TAINT_NOT;
1989     return 0;
1990 }
1991
1992 I32
1993 Perl_debop(pTHX_ const OP *o)
1994 {
1995     dVAR;
1996
1997     PERL_ARGS_ASSERT_DEBOP;
1998
1999     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2000         return 0;
2001
2002     Perl_deb(aTHX_ "%s", OP_NAME(o));
2003     switch (o->op_type) {
2004     case OP_CONST:
2005     case OP_HINTSEVAL:
2006         /* With ITHREADS, consts are stored in the pad, and the right pad
2007          * may not be active here, so check.
2008          * Looks like only during compiling the pads are illegal.
2009          */
2010 #ifdef USE_ITHREADS
2011         if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2012 #endif
2013             PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
2014         break;
2015     case OP_GVSV:
2016     case OP_GV:
2017         if (cGVOPo_gv) {
2018             SV * const sv = newSV(0);
2019 #ifdef PERL_MAD
2020             /* FIXME - is this making unwarranted assumptions about the
2021                UTF-8 cleanliness of the dump file handle?  */
2022             SvUTF8_on(sv);
2023 #endif
2024             gv_fullname3(sv, cGVOPo_gv, NULL);
2025             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2026             SvREFCNT_dec(sv);
2027         }
2028         else
2029             PerlIO_printf(Perl_debug_log, "(NULL)");
2030         break;
2031     case OP_PADSV:
2032     case OP_PADAV:
2033     case OP_PADHV:
2034         {
2035         /* print the lexical's name */
2036         CV * const cv = deb_curcv(cxstack_ix);
2037         SV *sv;
2038         if (cv) {
2039             AV * const padlist = CvPADLIST(cv);
2040             AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
2041             sv = *av_fetch(comppad, o->op_targ, FALSE);
2042         } else
2043             sv = NULL;
2044         if (sv)
2045             PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
2046         else
2047             PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
2048         }
2049         break;
2050     default:
2051         break;
2052     }
2053     PerlIO_printf(Perl_debug_log, "\n");
2054     return 0;
2055 }
2056
2057 STATIC CV*
2058 S_deb_curcv(pTHX_ const I32 ix)
2059 {
2060     dVAR;
2061     const PERL_CONTEXT * const cx = &cxstack[ix];
2062     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2063         return cx->blk_sub.cv;
2064     else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2065         return PL_compcv;
2066     else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2067         return PL_main_cv;
2068     else if (ix <= 0)
2069         return NULL;
2070     else
2071         return deb_curcv(ix - 1);
2072 }
2073
2074 void
2075 Perl_watch(pTHX_ char **addr)
2076 {
2077     dVAR;
2078
2079     PERL_ARGS_ASSERT_WATCH;
2080
2081     PL_watchaddr = addr;
2082     PL_watchok = *addr;
2083     PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2084         PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2085 }
2086
2087 STATIC void
2088 S_debprof(pTHX_ const OP *o)
2089 {
2090     dVAR;
2091
2092     PERL_ARGS_ASSERT_DEBPROF;
2093
2094     if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
2095         return;
2096     if (!PL_profiledata)
2097         Newxz(PL_profiledata, MAXO, U32);
2098     ++PL_profiledata[o->op_type];
2099 }
2100
2101 void
2102 Perl_debprofdump(pTHX)
2103 {
2104     dVAR;
2105     unsigned i;
2106     if (!PL_profiledata)
2107         return;
2108     for (i = 0; i < MAXO; i++) {
2109         if (PL_profiledata[i])
2110             PerlIO_printf(Perl_debug_log,
2111                           "%5lu %s\n", (unsigned long)PL_profiledata[i],
2112                                        PL_op_name[i]);
2113     }
2114 }
2115
2116 #ifdef PERL_MAD
2117 /*
2118  *    XML variants of most of the above routines
2119  */
2120
2121 STATIC void
2122 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2123 {
2124     va_list args;
2125
2126     PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2127
2128     PerlIO_printf(file, "\n    ");
2129     va_start(args, pat);
2130     xmldump_vindent(level, file, pat, &args);
2131     va_end(args);
2132 }
2133
2134
2135 void
2136 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2137 {
2138     va_list args;
2139     PERL_ARGS_ASSERT_XMLDUMP_INDENT;
2140     va_start(args, pat);
2141     xmldump_vindent(level, file, pat, &args);
2142     va_end(args);
2143 }
2144
2145 void
2146 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2147 {
2148     PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2149
2150     PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2151     PerlIO_vprintf(file, pat, *args);
2152 }
2153
2154 void
2155 Perl_xmldump_all(pTHX)
2156 {
2157     PerlIO_setlinebuf(PL_xmlfp);
2158     if (PL_main_root)
2159         op_xmldump(PL_main_root);
2160     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2161         PerlIO_close(PL_xmlfp);
2162     PL_xmlfp = 0;
2163 }
2164
2165 void
2166 Perl_xmldump_packsubs(pTHX_ const HV *stash)
2167 {
2168     I32 i;
2169     HE  *entry;
2170
2171     PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2172
2173     if (!HvARRAY(stash))
2174         return;
2175     for (i = 0; i <= (I32) HvMAX(stash); i++) {
2176         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
2177             GV *gv = (GV*)HeVAL(entry);
2178             HV *hv;
2179             if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2180                 continue;
2181             if (GvCVu(gv))
2182                 xmldump_sub(gv);
2183             if (GvFORM(gv))
2184                 xmldump_form(gv);
2185             if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2186                 && (hv = GvHV(gv)) && hv != PL_defstash)
2187                 xmldump_packsubs(hv);           /* nested package */
2188         }
2189     }
2190 }
2191
2192 void
2193 Perl_xmldump_sub(pTHX_ const GV *gv)
2194 {
2195     SV * const sv = sv_newmortal();
2196
2197     PERL_ARGS_ASSERT_XMLDUMP_SUB;
2198
2199     gv_fullname3(sv, gv, NULL);
2200     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2201     if (CvXSUB(GvCV(gv)))
2202         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2203             PTR2UV(CvXSUB(GvCV(gv))),
2204             (int)CvXSUBANY(GvCV(gv)).any_i32);
2205     else if (CvROOT(GvCV(gv)))
2206         op_xmldump(CvROOT(GvCV(gv)));
2207     else
2208         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2209 }
2210
2211 void
2212 Perl_xmldump_form(pTHX_ const GV *gv)
2213 {
2214     SV * const sv = sv_newmortal();
2215
2216     PERL_ARGS_ASSERT_XMLDUMP_FORM;
2217
2218     gv_fullname3(sv, gv, NULL);
2219     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2220     if (CvROOT(GvFORM(gv)))
2221         op_xmldump(CvROOT(GvFORM(gv)));
2222     else
2223         Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2224 }
2225
2226 void
2227 Perl_xmldump_eval(pTHX)
2228 {
2229     op_xmldump(PL_eval_root);
2230 }
2231
2232 char *
2233 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2234 {
2235     PERL_ARGS_ASSERT_SV_CATXMLSV;
2236     return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2237 }
2238
2239 char *
2240 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
2241 {
2242     unsigned int c;
2243     const char * const e = pv + len;
2244     const char * const start = pv;
2245     STRLEN dsvcur;
2246     STRLEN cl;
2247
2248     PERL_ARGS_ASSERT_SV_CATXMLPVN;
2249
2250     sv_catpvn(dsv,"",0);
2251     dsvcur = SvCUR(dsv);        /* in case we have to restart */
2252
2253   retry:
2254     while (pv < e) {
2255         if (utf8) {
2256             c = utf8_to_uvchr((U8*)pv, &cl);
2257             if (cl == 0) {
2258                 SvCUR(dsv) = dsvcur;
2259                 pv = start;
2260                 utf8 = 0;
2261                 goto retry;
2262             }
2263         }
2264         else
2265             c = (*pv & 255);
2266
2267         switch (c) {
2268         case 0x00:
2269         case 0x01:
2270         case 0x02:
2271         case 0x03:
2272         case 0x04:
2273         case 0x05:
2274         case 0x06:
2275         case 0x07:
2276         case 0x08:
2277         case 0x0b:
2278         case 0x0c:
2279         case 0x0e:
2280         case 0x0f:
2281         case 0x10:
2282         case 0x11:
2283         case 0x12:
2284         case 0x13:
2285         case 0x14:
2286         case 0x15:
2287         case 0x16:
2288         case 0x17:
2289         case 0x18:
2290         case 0x19:
2291         case 0x1a:
2292         case 0x1b:
2293         case 0x1c:
2294         case 0x1d:
2295         case 0x1e:
2296         case 0x1f:
2297         case 0x7f:
2298         case 0x80:
2299         case 0x81:
2300         case 0x82:
2301         case 0x83:
2302         case 0x84:
2303         case 0x86:
2304         case 0x87:
2305         case 0x88:
2306         case 0x89:
2307         case 0x90:
2308         case 0x91:
2309         case 0x92:
2310         case 0x93:
2311         case 0x94:
2312         case 0x95:
2313         case 0x96:
2314         case 0x97:
2315         case 0x98:
2316         case 0x99:
2317         case 0x9a:
2318         case 0x9b:
2319         case 0x9c:
2320         case 0x9d:
2321         case 0x9e:
2322         case 0x9f:
2323             Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2324             break;
2325         case '<':
2326             sv_catpvs(dsv, "&lt;");
2327             break;
2328         case '>':
2329             sv_catpvs(dsv, "&gt;");
2330             break;
2331         case '&':
2332             sv_catpvs(dsv, "&amp;");
2333             break;
2334         case '"':
2335             sv_catpvs(dsv, "&#34;");
2336             break;
2337         default:
2338             if (c < 0xD800) {
2339                 if (c < 32 || c > 127) {
2340                     Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2341                 }
2342                 else {
2343                     const char string = (char) c;
2344                     sv_catpvn(dsv, &string, 1);
2345                 }
2346                 break;
2347             }
2348             if ((c >= 0xD800 && c <= 0xDB7F) ||
2349                 (c >= 0xDC00 && c <= 0xDFFF) ||
2350                 (c >= 0xFFF0 && c <= 0xFFFF) ||
2351                  c > 0x10ffff)
2352                 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2353             else
2354                 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2355         }
2356
2357         if (utf8)
2358             pv += UTF8SKIP(pv);
2359         else
2360             pv++;
2361     }
2362
2363     return SvPVX(dsv);
2364 }
2365
2366 char *
2367 Perl_sv_xmlpeek(pTHX_ SV *sv)
2368 {
2369     SV * const t = sv_newmortal();
2370     STRLEN n_a;
2371     int unref = 0;
2372
2373     PERL_ARGS_ASSERT_SV_XMLPEEK;
2374
2375     sv_utf8_upgrade(t);
2376     sv_setpvn(t, "", 0);
2377     /* retry: */
2378     if (!sv) {
2379         sv_catpv(t, "VOID=\"\"");
2380         goto finish;
2381     }
2382     else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
2383         sv_catpv(t, "WILD=\"\"");
2384         goto finish;
2385     }
2386     else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2387         if (sv == &PL_sv_undef) {
2388             sv_catpv(t, "SV_UNDEF=\"1\"");
2389             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2390                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2391                 SvREADONLY(sv))
2392                 goto finish;
2393         }
2394         else if (sv == &PL_sv_no) {
2395             sv_catpv(t, "SV_NO=\"1\"");
2396             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2397                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2398                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2399                                   SVp_POK|SVp_NOK)) &&
2400                 SvCUR(sv) == 0 &&
2401                 SvNVX(sv) == 0.0)
2402                 goto finish;
2403         }
2404         else if (sv == &PL_sv_yes) {
2405             sv_catpv(t, "SV_YES=\"1\"");
2406             if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2407                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2408                 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2409                                   SVp_POK|SVp_NOK)) &&
2410                 SvCUR(sv) == 1 &&
2411                 SvPVX(sv) && *SvPVX(sv) == '1' &&
2412                 SvNVX(sv) == 1.0)
2413                 goto finish;
2414         }
2415         else {
2416             sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2417             if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2418                                  SVs_GMG|SVs_SMG|SVs_RMG)) &&
2419                 SvREADONLY(sv))
2420                 goto finish;
2421         }
2422         sv_catpv(t, " XXX=\"\" ");
2423     }
2424     else if (SvREFCNT(sv) == 0) {
2425         sv_catpv(t, " refcnt=\"0\"");
2426         unref++;
2427     }
2428     else if (DEBUG_R_TEST_) {
2429         int is_tmp = 0;
2430         I32 ix;
2431         /* is this SV on the tmps stack? */
2432         for (ix=PL_tmps_ix; ix>=0; ix--) {
2433             if (PL_tmps_stack[ix] == sv) {
2434                 is_tmp = 1;
2435                 break;
2436             }
2437         }
2438         if (SvREFCNT(sv) > 1)
2439             Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2440                     is_tmp ? "T" : "");
2441         else if (is_tmp)
2442             sv_catpv(t, " DRT=\"<T>\"");
2443     }
2444
2445     if (SvROK(sv)) {
2446         sv_catpv(t, " ROK=\"\"");
2447     }
2448     switch (SvTYPE(sv)) {
2449     default:
2450         sv_catpv(t, " FREED=\"1\"");
2451         goto finish;
2452
2453     case SVt_NULL:
2454         sv_catpv(t, " UNDEF=\"1\"");
2455         goto finish;
2456     case SVt_IV:
2457         sv_catpv(t, " IV=\"");
2458         break;
2459     case SVt_NV:
2460         sv_catpv(t, " NV=\"");
2461         break;
2462     case SVt_PV:
2463         sv_catpv(t, " PV=\"");
2464         break;
2465     case SVt_PVIV:
2466         sv_catpv(t, " PVIV=\"");
2467         break;
2468     case SVt_PVNV:
2469         sv_catpv(t, " PVNV=\"");
2470         break;
2471     case SVt_PVMG:
2472         sv_catpv(t, " PVMG=\"");
2473         break;
2474     case SVt_PVLV:
2475         sv_catpv(t, " PVLV=\"");
2476         break;
2477     case SVt_PVAV:
2478         sv_catpv(t, " AV=\"");
2479         break;
2480     case SVt_PVHV:
2481         sv_catpv(t, " HV=\"");
2482         break;
2483     case SVt_PVCV:
2484         if (CvGV(sv))
2485             Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2486         else
2487             sv_catpv(t, " CV=\"()\"");
2488         goto finish;
2489     case SVt_PVGV:
2490         sv_catpv(t, " GV=\"");
2491         break;
2492     case SVt_BIND:
2493         sv_catpv(t, " BIND=\"");
2494         break;
2495     case SVt_REGEXP:
2496         sv_catpv(t, " ORANGE=\"");
2497         break;
2498     case SVt_PVFM:
2499         sv_catpv(t, " FM=\"");
2500         break;
2501     case SVt_PVIO:
2502         sv_catpv(t, " IO=\"");
2503         break;
2504     }
2505
2506     if (SvPOKp(sv)) {
2507         if (SvPVX(sv)) {
2508             sv_catxmlsv(t, sv);
2509         }
2510     }
2511     else if (SvNOKp(sv)) {
2512         STORE_NUMERIC_LOCAL_SET_STANDARD();
2513         Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2514         RESTORE_NUMERIC_LOCAL();
2515     }
2516     else if (SvIOKp(sv)) {
2517         if (SvIsUV(sv))
2518             Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2519         else
2520             Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2521     }
2522     else
2523         sv_catpv(t, "");
2524     sv_catpv(t, "\"");
2525
2526   finish:
2527     while (unref--)
2528         sv_catpv(t, ")");
2529     return SvPV(t, n_a);
2530 }
2531
2532 void
2533 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2534 {
2535     PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2536
2537     if (!pm) {
2538         Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2539         return;
2540     }
2541     Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2542     level++;
2543     if (PM_GETRE(pm)) {
2544         REGEXP *const r = PM_GETRE(pm);
2545         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2546         sv_catxmlsv(tmpsv, (SV*)r);
2547         Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2548              SvPVX(tmpsv));
2549         SvREFCNT_dec(tmpsv);
2550         Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2551              (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2552     }
2553     else
2554         Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
2555     if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
2556         SV * const tmpsv = pm_description(pm);
2557         Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2558         SvREFCNT_dec(tmpsv);
2559     }
2560
2561     level--;
2562     if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
2563         Perl_xmldump_indent(aTHX_ level, file, ">\n");
2564         Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
2565         do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
2566         Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2567         Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2568     }
2569     else
2570         Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2571 }
2572
2573 void
2574 Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2575 {
2576     do_pmop_xmldump(0, PL_xmlfp, pm);
2577 }
2578
2579 void
2580 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2581 {
2582     UV      seq;
2583     int     contents = 0;
2584
2585     PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2586
2587     if (!o)
2588         return;
2589     sequence(o);
2590     seq = sequence_num(o);
2591     Perl_xmldump_indent(aTHX_ level, file,
2592         "<op_%s seq=\"%"UVuf" -> ",
2593              OP_NAME(o),
2594                       seq);
2595     level++;
2596     if (o->op_next)
2597         PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2598                       sequence_num(o->op_next));
2599     else
2600         PerlIO_printf(file, "DONE\"");
2601
2602     if (o->op_targ) {
2603         if (o->op_type == OP_NULL)
2604         {
2605             PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2606             if (o->op_targ == OP_NEXTSTATE)
2607             {
2608                 if (CopLINE(cCOPo))
2609                     PerlIO_printf(file, " line=\"%"UVuf"\"",
2610                                      (UV)CopLINE(cCOPo));
2611                 if (CopSTASHPV(cCOPo))
2612                     PerlIO_printf(file, " package=\"%s\"",
2613                                      CopSTASHPV(cCOPo));
2614                 if (CopLABEL(cCOPo))
2615                     PerlIO_printf(file, " label=\"%s\"",
2616                                      CopLABEL(cCOPo));
2617             }
2618         }
2619         else
2620             PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2621     }
2622 #ifdef DUMPADDR
2623     PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2624 #endif
2625     if (o->op_flags) {
2626         SV * const tmpsv = newSVpvn("", 0);
2627         switch (o->op_flags & OPf_WANT) {
2628         case OPf_WANT_VOID:
2629             sv_catpv(tmpsv, ",VOID");
2630             break;
2631         case OPf_WANT_SCALAR:
2632             sv_catpv(tmpsv, ",SCALAR");
2633             break;
2634         case OPf_WANT_LIST:
2635             sv_catpv(tmpsv, ",LIST");
2636             break;
2637         default:
2638             sv_catpv(tmpsv, ",UNKNOWN");
2639             break;
2640         }
2641         if (o->op_flags & OPf_KIDS)
2642             sv_catpv(tmpsv, ",KIDS");
2643         if (o->op_flags & OPf_PARENS)
2644             sv_catpv(tmpsv, ",PARENS");
2645         if (o->op_flags & OPf_STACKED)
2646             sv_catpv(tmpsv, ",STACKED");
2647         if (o->op_flags & OPf_REF)
2648             sv_catpv(tmpsv, ",REF");
2649         if (o->op_flags & OPf_MOD)
2650             sv_catpv(tmpsv, ",MOD");
2651         if (o->op_flags & OPf_SPECIAL)
2652             sv_catpv(tmpsv, ",SPECIAL");
2653         PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2654         SvREFCNT_dec(tmpsv);
2655     }
2656     if (o->op_private) {
2657         SV * const tmpsv = newSVpvn("", 0);
2658         if (PL_opargs[o->op_type] & OA_TARGLEX) {
2659             if (o->op_private & OPpTARGET_MY)
2660                 sv_catpv(tmpsv, ",TARGET_MY");
2661         }
2662         else if (o->op_type == OP_LEAVESUB ||
2663                  o->op_type == OP_LEAVE ||
2664                  o->op_type == OP_LEAVESUBLV ||
2665                  o->op_type == OP_LEAVEWRITE) {
2666             if (o->op_private & OPpREFCOUNTED)
2667                 sv_catpv(tmpsv, ",REFCOUNTED");
2668         }
2669         else if (o->op_type == OP_AASSIGN) {
2670             if (o->op_private & OPpASSIGN_COMMON)
2671                 sv_catpv(tmpsv, ",COMMON");
2672         }
2673         else if (o->op_type == OP_SASSIGN) {
2674             if (o->op_private & OPpASSIGN_BACKWARDS)
2675                 sv_catpv(tmpsv, ",BACKWARDS");
2676         }
2677         else if (o->op_type == OP_TRANS) {
2678             if (o->op_private & OPpTRANS_SQUASH)
2679                 sv_catpv(tmpsv, ",SQUASH");
2680             if (o->op_private & OPpTRANS_DELETE)
2681                 sv_catpv(tmpsv, ",DELETE");
2682             if (o->op_private & OPpTRANS_COMPLEMENT)
2683                 sv_catpv(tmpsv, ",COMPLEMENT");
2684             if (o->op_private & OPpTRANS_IDENTICAL)
2685                 sv_catpv(tmpsv, ",IDENTICAL");
2686             if (o->op_private & OPpTRANS_GROWS)
2687                 sv_catpv(tmpsv, ",GROWS");
2688         }
2689         else if (o->op_type == OP_REPEAT) {
2690             if (o->op_private & OPpREPEAT_DOLIST)
2691                 sv_catpv(tmpsv, ",DOLIST");
2692         }
2693         else if (o->op_type == OP_ENTERSUB ||
2694                  o->op_type == OP_RV2SV ||
2695                  o->op_type == OP_GVSV ||
2696                  o->op_type == OP_RV2AV ||
2697                  o->op_type == OP_RV2HV ||
2698                  o->op_type == OP_RV2GV ||
2699                  o->op_type == OP_AELEM ||
2700                  o->op_type == OP_HELEM )
2701         {
2702             if (o->op_type == OP_ENTERSUB) {
2703                 if (o->op_private & OPpENTERSUB_AMPER)
2704                     sv_catpv(tmpsv, ",AMPER");
2705                 if (o->op_private & OPpENTERSUB_DB)
2706                     sv_catpv(tmpsv, ",DB");
2707                 if (o->op_private & OPpENTERSUB_HASTARG)
2708                     sv_catpv(tmpsv, ",HASTARG");
2709                 if (o->op_private & OPpENTERSUB_NOPAREN)
2710                     sv_catpv(tmpsv, ",NOPAREN");
2711                 if (o->op_private & OPpENTERSUB_INARGS)
2712                     sv_catpv(tmpsv, ",INARGS");
2713                 if (o->op_private & OPpENTERSUB_NOMOD)
2714                     sv_catpv(tmpsv, ",NOMOD");
2715             }
2716             else {
2717                 switch (o->op_private & OPpDEREF) {
2718             case OPpDEREF_SV:
2719                 sv_catpv(tmpsv, ",SV");
2720                 break;
2721             case OPpDEREF_AV:
2722                 sv_catpv(tmpsv, ",AV");
2723                 break;
2724             case OPpDEREF_HV:
2725                 sv_catpv(tmpsv, ",HV");
2726                 break;
2727             }
2728                 if (o->op_private & OPpMAYBE_LVSUB)
2729                     sv_catpv(tmpsv, ",MAYBE_LVSUB");
2730             }
2731             if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2732                 if (o->op_private & OPpLVAL_DEFER)
2733                     sv_catpv(tmpsv, ",LVAL_DEFER");
2734             }
2735             else {
2736                 if (o->op_private & HINT_STRICT_REFS)
2737                     sv_catpv(tmpsv, ",STRICT_REFS");
2738                 if (o->op_private & OPpOUR_INTRO)
2739                     sv_catpv(tmpsv, ",OUR_INTRO");
2740             }
2741         }
2742         else if (o->op_type == OP_CONST) {
2743             if (o->op_private & OPpCONST_BARE)
2744                 sv_catpv(tmpsv, ",BARE");
2745             if (o->op_private & OPpCONST_STRICT)
2746                 sv_catpv(tmpsv, ",STRICT");
2747             if (o->op_private & OPpCONST_ARYBASE)
2748                 sv_catpv(tmpsv, ",ARYBASE");
2749             if (o->op_private & OPpCONST_WARNING)
2750                 sv_catpv(tmpsv, ",WARNING");
2751             if (o->op_private & OPpCONST_ENTERED)
2752                 sv_catpv(tmpsv, ",ENTERED");
2753         }
2754         else if (o->op_type == OP_FLIP) {
2755             if (o->op_private & OPpFLIP_LINENUM)
2756                 sv_catpv(tmpsv, ",LINENUM");
2757         }
2758         else if (o->op_type == OP_FLOP) {
2759             if (o->op_private & OPpFLIP_LINENUM)
2760                 sv_catpv(tmpsv, ",LINENUM");
2761         }
2762         else if (o->op_type == OP_RV2CV) {
2763             if (o->op_private & OPpLVAL_INTRO)
2764                 sv_catpv(tmpsv, ",INTRO");
2765         }
2766         else if (o->op_type == OP_GV) {
2767             if (o->op_private & OPpEARLY_CV)
2768                 sv_catpv(tmpsv, ",EARLY_CV");
2769         }
2770         else if (o->op_type == OP_LIST) {
2771             if (o->op_private & OPpLIST_GUESSED)
2772                 sv_catpv(tmpsv, ",GUESSED");
2773         }
2774         else if (o->op_type == OP_DELETE) {
2775             if (o->op_private & OPpSLICE)
2776                 sv_catpv(tmpsv, ",SLICE");
2777         }
2778         else if (o->op_type == OP_EXISTS) {
2779             if (o->op_private & OPpEXISTS_SUB)
2780                 sv_catpv(tmpsv, ",EXISTS_SUB");
2781         }
2782         else if (o->op_type == OP_SORT) {
2783             if (o->op_private & OPpSORT_NUMERIC)
2784                 sv_catpv(tmpsv, ",NUMERIC");
2785             if (o->op_private & OPpSORT_INTEGER)
2786                 sv_catpv(tmpsv, ",INTEGER");
2787             if (o->op_private & OPpSORT_REVERSE)
2788                 sv_catpv(tmpsv, ",REVERSE");
2789         }
2790         else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2791             if (o->op_private & OPpOPEN_IN_RAW)
2792                 sv_catpv(tmpsv, ",IN_RAW");
2793             if (o->op_private & OPpOPEN_IN_CRLF)
2794                 sv_catpv(tmpsv, ",IN_CRLF");
2795             if (o->op_private & OPpOPEN_OUT_RAW)
2796                 sv_catpv(tmpsv, ",OUT_RAW");
2797             if (o->op_private & OPpOPEN_OUT_CRLF)
2798                 sv_catpv(tmpsv, ",OUT_CRLF");
2799         }
2800         else if (o->op_type == OP_EXIT) {
2801             if (o->op_private & OPpEXIT_VMSISH)
2802                 sv_catpv(tmpsv, ",EXIT_VMSISH");
2803             if (o->op_private & OPpHUSH_VMSISH)
2804                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2805         }
2806         else if (o->op_type == OP_DIE) {
2807             if (o->op_private & OPpHUSH_VMSISH)
2808                 sv_catpv(tmpsv, ",HUSH_VMSISH");
2809         }
2810         else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
2811             if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
2812                 sv_catpv(tmpsv, ",FT_ACCESS");
2813             if (o->op_private & OPpFT_STACKED)
2814                 sv_catpv(tmpsv, ",FT_STACKED");
2815         }
2816         if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2817             sv_catpv(tmpsv, ",INTRO");
2818         if (SvCUR(tmpsv))
2819             S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2820         SvREFCNT_dec(tmpsv);
2821     }
2822
2823     switch (o->op_type) {
2824     case OP_AELEMFAST:
2825         if (o->op_flags & OPf_SPECIAL) {
2826             break;
2827         }
2828     case OP_GVSV:
2829     case OP_GV:
2830 #ifdef USE_ITHREADS
2831         S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2832 #else
2833         if (cSVOPo->op_sv) {
2834             SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2835             SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
2836             char *s;
2837             STRLEN len;
2838             ENTER;
2839             SAVEFREESV(tmpsv1);
2840             SAVEFREESV(tmpsv2);
2841             gv_fullname3(tmpsv1, (GV*)cSVOPo->op_sv, NULL);
2842             s = SvPV(tmpsv1,len);
2843             sv_catxmlpvn(tmpsv2, s, len, 1);
2844             S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2845             LEAVE;
2846         }
2847         else
2848             S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2849 #endif
2850         break;
2851     case OP_CONST:
2852     case OP_HINTSEVAL:
2853     case OP_METHOD_NAMED:
2854 #ifndef USE_ITHREADS
2855         /* with ITHREADS, consts are stored in the pad, and the right pad
2856          * may not be active here, so skip */
2857         S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2858 #endif
2859         break;
2860     case OP_ANONCODE:
2861         if (!contents) {
2862             contents = 1;
2863             PerlIO_printf(file, ">\n");
2864         }
2865         do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2866         break;
2867     case OP_NEXTSTATE:
2868     case OP_DBSTATE:
2869         if (CopLINE(cCOPo))
2870             S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
2871                              (UV)CopLINE(cCOPo));
2872         if (CopSTASHPV(cCOPo))
2873             S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2874                              CopSTASHPV(cCOPo));
2875         if (CopLABEL(cCOPo))
2876             S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
2877                              CopLABEL(cCOPo));
2878         break;
2879     case OP_ENTERLOOP:
2880         S_xmldump_attr(aTHX_ level, file, "redo=\"");
2881         if (cLOOPo->op_redoop)
2882             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2883         else
2884             PerlIO_printf(file, "DONE\"");
2885         S_xmldump_attr(aTHX_ level, file, "next=\"");
2886         if (cLOOPo->op_nextop)
2887             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2888         else
2889             PerlIO_printf(file, "DONE\"");
2890         S_xmldump_attr(aTHX_ level, file, "last=\"");
2891         if (cLOOPo->op_lastop)
2892             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2893         else
2894             PerlIO_printf(file, "DONE\"");
2895         break;
2896     case OP_COND_EXPR:
2897     case OP_RANGE:
2898     case OP_MAPWHILE:
2899     case OP_GREPWHILE:
2900     case OP_OR:
2901     case OP_AND:
2902         S_xmldump_attr(aTHX_ level, file, "other=\"");
2903         if (cLOGOPo->op_other)
2904             PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2905         else
2906             PerlIO_printf(file, "DONE\"");
2907         break;
2908     case OP_LEAVE:
2909     case OP_LEAVEEVAL:
2910     case OP_LEAVESUB:
2911     case OP_LEAVESUBLV:
2912     case OP_LEAVEWRITE:
2913     case OP_SCOPE:
2914         if (o->op_private & OPpREFCOUNTED)
2915             S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2916         break;
2917     default:
2918         break;
2919     }
2920
2921     if (PL_madskills && o->op_madprop) {
2922         char prevkey = '\0';
2923         SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
2924         const MADPROP* mp = o->op_madprop;
2925
2926         if (!contents) {
2927             contents = 1;
2928             PerlIO_printf(file, ">\n");
2929         }
2930         Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2931         level++;
2932         while (mp) {
2933             char tmp = mp->mad_key;
2934             sv_setpvn(tmpsv,"\"",1);
2935             if (tmp)
2936                 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
2937             if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2938                 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2939             else
2940                 prevkey = tmp;
2941             sv_catpv(tmpsv, "\"");
2942             switch (mp->mad_type) {
2943             case MAD_NULL:
2944                 sv_catpv(tmpsv, "NULL");
2945                 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2946                 break;
2947             case MAD_PV:
2948                 sv_catpv(tmpsv, " val=\"");
2949                 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2950                 sv_catpv(tmpsv, "\"");
2951                 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2952                 break;
2953             case MAD_SV:
2954                 sv_catpv(tmpsv, " val=\"");
2955                 sv_catxmlsv(tmpsv, (SV*)mp->mad_val);
2956                 sv_catpv(tmpsv, "\"");
2957                 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2958                 break;
2959             case MAD_OP:
2960                 if ((OP*)mp->mad_val) {
2961                     Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2962                     do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2963                     Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2964                 }
2965                 break;
2966             default:
2967                 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2968                 break;
2969             }
2970             mp = mp->mad_next;
2971         }
2972         level--;
2973         Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2974
2975         SvREFCNT_dec(tmpsv);
2976     }
2977
2978     switch (o->op_type) {
2979     case OP_PUSHRE:
2980     case OP_MATCH:
2981     case OP_QR:
2982     case OP_SUBST:
2983         if (!contents) {
2984             contents = 1;
2985             PerlIO_printf(file, ">\n");
2986         }
2987         do_pmop_xmldump(level, file, cPMOPo);
2988         break;
2989     default:
2990         break;
2991     }
2992
2993     if (o->op_flags & OPf_KIDS) {
2994         OP *kid;
2995         if (!contents) {
2996             contents = 1;
2997             PerlIO_printf(file, ">\n");
2998         }
2999         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3000             do_op_xmldump(level, file, kid);
3001     }
3002
3003     if (contents)
3004         Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3005     else
3006         PerlIO_printf(file, " />\n");
3007 }
3008
3009 void
3010 Perl_op_xmldump(pTHX_ const OP *o)
3011 {
3012     PERL_ARGS_ASSERT_OP_XMLDUMP;
3013
3014     do_op_xmldump(0, PL_xmlfp, o);
3015 }
3016 #endif
3017
3018 /*
3019  * Local variables:
3020  * c-indentation-style: bsd
3021  * c-basic-offset: 4
3022  * indent-tabs-mode: t
3023  * End:
3024  *
3025  * ex: set ts=8 sts=4 sw=4 noet:
3026  */