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