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