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