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