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