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