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