This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Record folded constants in the op tree
[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 }
07bc277f 675 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
68d4833d 676 sv_catpv(desc, ",SKIPWHITE");
4199688e 677 }
68d4833d 678
a0c2f4dd 679 append_flags(desc, pmflags, pmflags_flags_names);
4199688e
AL
680 return desc;
681}
682
3967c732 683void
864dbfa3 684Perl_pmop_dump(pTHX_ PMOP *pm)
3967c732
JD
685{
686 do_pmop_dump(0, Perl_debug_log, pm);
79072805
LW
687}
688
b6f05621
DM
689/* Return a unique integer to represent the address of op o.
690 * If it already exists in PL_op_sequence, just return it;
691 * otherwise add it.
692 * *** Note that this isn't thread-safe */
294b3b39 693
2814eb74 694STATIC UV
0bd48802 695S_sequence_num(pTHX_ const OP *o)
2814eb74 696{
27da23d5 697 dVAR;
2814eb74
PJ
698 SV *op,
699 **seq;
93524f2b 700 const char *key;
2814eb74 701 STRLEN len;
b6f05621
DM
702 if (!o)
703 return 0;
c0fd1b42 704 op = newSVuv(PTR2UV(o));
b6f05621 705 sv_2mortal(op);
93524f2b 706 key = SvPV_const(op, len);
b6f05621
DM
707 if (!PL_op_sequence)
708 PL_op_sequence = newHV();
709 seq = hv_fetch(PL_op_sequence, key, len, 0);
710 if (seq)
711 return SvUV(*seq);
712 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
713 return PL_op_seq;
2814eb74
PJ
714}
715
a0c2f4dd
NC
716const struct flag_to_name op_flags_names[] = {
717 {OPf_KIDS, ",KIDS"},
718 {OPf_PARENS, ",PARENS"},
a0c2f4dd
NC
719 {OPf_REF, ",REF"},
720 {OPf_MOD, ",MOD"},
65cccc5e 721 {OPf_STACKED, ",STACKED"},
a0c2f4dd
NC
722 {OPf_SPECIAL, ",SPECIAL"}
723};
724
ea9ad1f2 725const struct flag_to_name op_trans_names[] = {
65cccc5e
VP
726 {OPpTRANS_FROM_UTF, ",FROM_UTF"},
727 {OPpTRANS_TO_UTF, ",TO_UTF"},
728 {OPpTRANS_IDENTICAL, ",IDENTICAL"},
ea9ad1f2 729 {OPpTRANS_SQUASH, ",SQUASH"},
ea9ad1f2 730 {OPpTRANS_COMPLEMENT, ",COMPLEMENT"},
65cccc5e
VP
731 {OPpTRANS_GROWS, ",GROWS"},
732 {OPpTRANS_DELETE, ",DELETE"}
ea9ad1f2
NC
733};
734
735const struct flag_to_name op_entersub_names[] = {
ea9ad1f2
NC
736 {OPpENTERSUB_DB, ",DB"},
737 {OPpENTERSUB_HASTARG, ",HASTARG"},
65cccc5e 738 {OPpENTERSUB_AMPER, ",AMPER"},
ea9ad1f2 739 {OPpENTERSUB_NOPAREN, ",NOPAREN"},
65cccc5e 740 {OPpENTERSUB_INARGS, ",INARGS"}
ea9ad1f2
NC
741};
742
743const struct flag_to_name op_const_names[] = {
65cccc5e
VP
744 {OPpCONST_NOVER, ",NOVER"},
745 {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"},
ea9ad1f2 746 {OPpCONST_STRICT, ",STRICT"},
65cccc5e 747 {OPpCONST_ENTERED, ",ENTERED"},
cc2ebcd7 748 {OPpCONST_FOLDED, ",FOLDED"},
63e0918d 749 {OPpCONST_BARE, ",BARE"}
ea9ad1f2
NC
750};
751
752const struct flag_to_name op_sort_names[] = {
753 {OPpSORT_NUMERIC, ",NUMERIC"},
754 {OPpSORT_INTEGER, ",INTEGER"},
65cccc5e
VP
755 {OPpSORT_REVERSE, ",REVERSE"},
756 {OPpSORT_INPLACE, ",INPLACE"},
757 {OPpSORT_DESCEND, ",DESCEND"},
758 {OPpSORT_QSORT, ",QSORT"},
759 {OPpSORT_STABLE, ",STABLE"}
ea9ad1f2
NC
760};
761
762const struct flag_to_name op_open_names[] = {
763 {OPpOPEN_IN_RAW, ",IN_RAW"},
764 {OPpOPEN_IN_CRLF, ",IN_CRLF"},
765 {OPpOPEN_OUT_RAW, ",OUT_RAW"},
766 {OPpOPEN_OUT_CRLF, ",OUT_CRLF"}
767};
768
261c990e
NC
769const struct flag_to_name op_exit_names[] = {
770 {OPpEXIT_VMSISH, ",EXIT_VMSISH"},
771 {OPpHUSH_VMSISH, ",HUSH_VMSISH"}
772};
773
774#define OP_PRIVATE_ONCE(op, flag, name) \
775 const struct flag_to_name CAT2(op, _names)[] = { \
776 {(flag), (name)} \
f58883a1 777 }
261c990e
NC
778
779OP_PRIVATE_ONCE(op_aassign, OPpASSIGN_COMMON, ",COMMON");
780OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED");
781OP_PRIVATE_ONCE(op_sassign, OPpASSIGN_BACKWARDS, ",BACKWARDS");
782OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST");
65cccc5e 783OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE");
261c990e
NC
784OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO");
785OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM");
786OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV");
787OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED");
788OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE");
789OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB");
790OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH");
791
1fe3abee
NC
792struct op_private_by_op {
793 U16 op_type;
794 U16 len;
795 const struct flag_to_name *start;
796};
797
798const struct op_private_by_op op_private_names[] = {
261c990e
NC
799 {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
800 {OP_LEAVE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
801 {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
802 {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names },
803 {OP_AASSIGN, C_ARRAY_LENGTH(op_aassign_names), op_aassign_names },
804 {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names },
805 {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names },
806 {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names },
807 {OP_EXIT, C_ARRAY_LENGTH(op_exit_names), op_exit_names },
808 {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
809 {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names },
810 {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names },
811 {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names },
812 {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names },
813 {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names },
814 {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names },
1fe3abee
NC
815 {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names },
816 {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names },
817 {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names },
818 {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names },
819 {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names }
820};
821
822static bool
823S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) {
824 const struct op_private_by_op *start = op_private_names;
825 const struct op_private_by_op *const end
826 = op_private_names + C_ARRAY_LENGTH(op_private_names);
827
828 /* This is a linear search, but no worse than the code that it replaced.
829 It's debugging code - size is more important than speed. */
830 do {
831 if (optype == start->op_type) {
832 S_append_flags(aTHX_ tmpsv, op_private, start->start,
833 start->start + start->len);
834 return TRUE;
835 }
836 } while (++start < end);
837 return FALSE;
838}
839
79072805 840void
6867be6d 841Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
79072805 842{
27da23d5 843 dVAR;
2814eb74 844 UV seq;
e15d5972
AL
845 const OPCODE optype = o->op_type;
846
7918f24d
NC
847 PERL_ARGS_ASSERT_DO_OP_DUMP;
848
cea2e8a9 849 Perl_dump_indent(aTHX_ level, file, "{\n");
3967c732 850 level++;
0bd48802 851 seq = sequence_num(o);
2814eb74 852 if (seq)
f5992bc4 853 PerlIO_printf(file, "%-4"UVuf, seq);
93a17b20 854 else
b6f05621 855 PerlIO_printf(file, "????");
c8db6e60
JH
856 PerlIO_printf(file,
857 "%*sTYPE = %s ===> ",
53e06cf0 858 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
2814eb74 859 if (o->op_next)
b6f05621
DM
860 PerlIO_printf(file,
861 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
666ea192 862 sequence_num(o->op_next));
79072805 863 else
e75ab6ad 864 PerlIO_printf(file, "NULL\n");
11343788 865 if (o->op_targ) {
e15d5972 866 if (optype == OP_NULL) {
cea2e8a9 867 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
e15d5972 868 if (o->op_targ == OP_NEXTSTATE) {
ae7d165c 869 if (CopLINE(cCOPo))
f5992bc4 870 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
9d98dee5 871 (UV)CopLINE(cCOPo));
ae7d165c
PJ
872 if (CopSTASHPV(cCOPo))
873 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
874 CopSTASHPV(cCOPo));
4b65a919 875 if (CopLABEL(cCOPo))
ae7d165c 876 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
4b65a919 877 CopLABEL(cCOPo));
ae7d165c
PJ
878 }
879 }
8990e307 880 else
894356b3 881 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
8990e307 882 }
748a9306 883#ifdef DUMPADDR
57def98f 884 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
79072805 885#endif
7e5d8ed2 886 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) {
e15d5972 887 SV * const tmpsv = newSVpvs("");
5dc0d613 888 switch (o->op_flags & OPf_WANT) {
54310121 889 case OPf_WANT_VOID:
46fc3d4c 890 sv_catpv(tmpsv, ",VOID");
54310121
PP
891 break;
892 case OPf_WANT_SCALAR:
46fc3d4c 893 sv_catpv(tmpsv, ",SCALAR");
54310121
PP
894 break;
895 case OPf_WANT_LIST:
46fc3d4c 896 sv_catpv(tmpsv, ",LIST");
54310121
PP
897 break;
898 default:
46fc3d4c 899 sv_catpv(tmpsv, ",UNKNOWN");
54310121
PP
900 break;
901 }
a0c2f4dd 902 append_flags(tmpsv, o->op_flags, op_flags_names);
29522234
DM
903 if (o->op_latefree)
904 sv_catpv(tmpsv, ",LATEFREE");
905 if (o->op_latefreed)
906 sv_catpv(tmpsv, ",LATEFREED");
7e5d8ed2
DM
907 if (o->op_attached)
908 sv_catpv(tmpsv, ",ATTACHED");
b15aece3 909 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
46fc3d4c 910 SvREFCNT_dec(tmpsv);
79072805 911 }
11343788 912 if (o->op_private) {
e15d5972
AL
913 SV * const tmpsv = newSVpvs("");
914 if (PL_opargs[optype] & OA_TARGLEX) {
07447971
GS
915 if (o->op_private & OPpTARGET_MY)
916 sv_catpv(tmpsv, ",TARGET_MY");
917 }
e15d5972 918 else if (optype == OP_ENTERSUB ||
5c135d48
NC
919 optype == OP_RV2SV ||
920 optype == OP_GVSV ||
921 optype == OP_RV2AV ||
922 optype == OP_RV2HV ||
923 optype == OP_RV2GV ||
924 optype == OP_AELEM ||
925 optype == OP_HELEM )
85e6fe83 926 {
e15d5972 927 if (optype == OP_ENTERSUB) {
ea9ad1f2 928 append_flags(tmpsv, o->op_private, op_entersub_names);
68dc0745 929 }
bf91b999 930 else {
d3011074 931 switch (o->op_private & OPpDEREF) {
b9ac451d
AL
932 case OPpDEREF_SV:
933 sv_catpv(tmpsv, ",SV");
934 break;
935 case OPpDEREF_AV:
936 sv_catpv(tmpsv, ",AV");
937 break;
938 case OPpDEREF_HV:
939 sv_catpv(tmpsv, ",HV");
940 break;
941 }
bf91b999
SC
942 if (o->op_private & OPpMAYBE_LVSUB)
943 sv_catpv(tmpsv, ",MAYBE_LVSUB");
944 }
0824d667 945
e15d5972 946 if (optype == OP_AELEM || optype == OP_HELEM) {
5dc0d613 947 if (o->op_private & OPpLVAL_DEFER)
46fc3d4c 948 sv_catpv(tmpsv, ",LVAL_DEFER");
68dc0745
PP
949 }
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,"},
1418 {RXf_SPLIT, "SPLIT,"},
1419 {RXf_COPY_DONE, "COPY_DONE,"},
1420 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1421 {RXf_TAINTED, "TAINTED,"},
1422 {RXf_START_ONLY, "START_ONLY,"},
1423 {RXf_SKIPWHITE, "SKIPWHITE,"},
1424 {RXf_WHITE, "WHITE,"},
1425 {RXf_NULL, "NULL,"},
1426};
1427
3967c732 1428void
864dbfa3 1429Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1430{
97aff369 1431 dVAR;
cea89e20 1432 SV *d;
e1ec3a88 1433 const char *s;
3967c732
JD
1434 U32 flags;
1435 U32 type;
1436
7918f24d
NC
1437 PERL_ARGS_ASSERT_DO_SV_DUMP;
1438
3967c732 1439 if (!sv) {
cea2e8a9 1440 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1441 return;
378cc40b 1442 }
2ef28da1 1443
3967c732
JD
1444 flags = SvFLAGS(sv);
1445 type = SvTYPE(sv);
79072805 1446
e0bbf362
DM
1447 /* process general SV flags */
1448
cea89e20 1449 d = Perl_newSVpvf(aTHX_
57def98f 1450 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
56431972 1451 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS
1452 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1453 (int)(PL_dumpindent*level), "");
8d063cd8 1454
1979170b
NC
1455 if (!((flags & SVpad_NAME) == SVpad_NAME
1456 && (type == SVt_PVMG || type == SVt_PVNV))) {
9a214eec
DM
1457 if ((flags & SVs_PADMY) && (flags & SVs_PADSTALE))
1458 sv_catpv(d, "PADSTALE,");
e604303a 1459 }
1979170b 1460 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
9a214eec
DM
1461 if (!(flags & SVs_PADMY) && (flags & SVs_PADTMP))
1462 sv_catpv(d, "PADTMP,");
e604303a
NC
1463 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
1464 }
a0c2f4dd 1465 append_flags(d, flags, first_sv_flags_names);
810b8aa5
GS
1466 if (flags & SVf_ROK) {
1467 sv_catpv(d, "ROK,");
1468 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1469 }
a0c2f4dd 1470 append_flags(d, flags, second_sv_flags_names);
1ccdb730
NC
1471 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
1472 if (SvPCS_IMPORTED(sv))
1473 sv_catpv(d, "PCS_IMPORTED,");
1474 else
9660f481 1475 sv_catpv(d, "SCREAM,");
1ccdb730 1476 }
3967c732 1477
e0bbf362
DM
1478 /* process type-specific SV flags */
1479
3967c732
JD
1480 switch (type) {
1481 case SVt_PVCV:
1482 case SVt_PVFM:
ae1f06a1 1483 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD
1484 break;
1485 case SVt_PVHV:
ae1f06a1 1486 append_flags(d, flags, hv_flags_names);
3967c732 1487 break;
926fc7b6
DM
1488 case SVt_PVGV:
1489 case SVt_PVLV:
1490 if (isGV_with_GP(sv)) {
ae1f06a1 1491 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1492 }
926fc7b6 1493 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD
1494 sv_catpv(d, "IMPORT");
1495 if (GvIMPORTED(sv) == GVf_IMPORTED)
1496 sv_catpv(d, "ALL,");
1497 else {
1498 sv_catpv(d, "(");
ae1f06a1 1499 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
3967c732
JD
1500 sv_catpv(d, " ),");
1501 }
1502 }
addd1794 1503 /* FALL THROUGH */
25da4f38 1504 default:
e604303a 1505 evaled_or_uv:
25da4f38 1506 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
69c678eb 1507 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1508 break;
addd1794 1509 case SVt_PVMG:
c13a5c80
NC
1510 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1511 if (SvVALID(sv)) sv_catpv(d, "VALID,");
00b1698f 1512 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
e604303a 1513 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
2e94196c 1514 /* FALL THROUGH */
e604303a
NC
1515 case SVt_PVNV:
1516 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1517 goto evaled_or_uv;
11ca45c0
NC
1518 case SVt_PVAV:
1519 break;
3967c732 1520 }
86f0d186
NC
1521 /* SVphv_SHAREKEYS is also 0x20000000 */
1522 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1523 sv_catpv(d, "UTF8");
3967c732 1524
b162af07
SP
1525 if (*(SvEND(d) - 1) == ',') {
1526 SvCUR_set(d, SvCUR(d) - 1);
1527 SvPVX(d)[SvCUR(d)] = '\0';
1528 }
3967c732 1529 sv_catpv(d, ")");
b15aece3 1530 s = SvPVX_const(d);
3967c732 1531
e0bbf362
DM
1532 /* dump initial SV details */
1533
fd0854ff 1534#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1535 Perl_dump_indent(aTHX_ level, file,
cd676548 1536 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
fd0854ff
DM
1537 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1538 sv->sv_debug_line,
1539 sv->sv_debug_inpad ? "for" : "by",
1540 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1541 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM
1542 sv->sv_debug_serial
1543 );
fd0854ff 1544#endif
cea2e8a9 1545 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM
1546
1547 /* Dump SV type */
1548
5357ca29
NC
1549 if (type < SVt_LAST) {
1550 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1551
1552 if (type == SVt_NULL) {
1553 SvREFCNT_dec(d);
1554 return;
1555 }
1556 } else {
faccc32b 1557 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
cea89e20 1558 SvREFCNT_dec(d);
3967c732
JD
1559 return;
1560 }
e0bbf362
DM
1561
1562 /* Dump general SV fields */
1563
27bd069f 1564 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC
1565 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1566 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1567 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1568 if (SvIsUV(sv)
f8c7b90f 1569#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC
1570 || SvIsCOW(sv)
1571#endif
1572 )
57def98f 1573 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1574 else
57def98f 1575 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
f8c7b90f 1576#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC
1577 if (SvIsCOW_shared_hash(sv))
1578 PerlIO_printf(file, " (HASH)");
1579 else if (SvIsCOW_normal(sv))
1580 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1581#endif
3967c732
JD
1582 PerlIO_putc(file, '\n');
1583 }
e0bbf362 1584
1979170b
NC
1585 if ((type == SVt_PVNV || type == SVt_PVMG)
1586 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
0e4c4423
NC
1587 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1588 (UV) COP_SEQ_RANGE_LOW(sv));
1589 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1590 (UV) COP_SEQ_RANGE_HIGH(sv));
1591 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1592 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1593 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1594 || type == SVt_NV) {
e54dc35b 1595 STORE_NUMERIC_LOCAL_SET_STANDARD();
57def98f 1596 /* %Vg doesn't work? --jhi */
cf2093f6 1597#ifdef USE_LONG_DOUBLE
2d4389e4 1598 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
cf2093f6 1599#else
cea2e8a9 1600 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
cf2093f6 1601#endif
e54dc35b 1602 RESTORE_NUMERIC_LOCAL();
3967c732 1603 }
e0bbf362 1604
3967c732 1605 if (SvROK(sv)) {
57def98f 1606 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732
JD
1607 if (nest < maxnest)
1608 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1609 }
e0bbf362 1610
cea89e20
JH
1611 if (type < SVt_PV) {
1612 SvREFCNT_dec(d);
3967c732 1613 return;
cea89e20 1614 }
e0bbf362 1615
a49b46c6 1616 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
b15aece3 1617 if (SvPVX_const(sv)) {
69240efd 1618 STRLEN delta;
7a4bba22 1619 if (SvOOK(sv)) {
69240efd 1620 SvOOK_offset(sv, delta);
7a4bba22 1621 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
5186cc12 1622 (UV) delta);
69240efd
NC
1623 } else {
1624 delta = 0;
7a4bba22 1625 }
b15aece3 1626 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
7a4bba22
NC
1627 if (SvOOK(sv)) {
1628 PerlIO_printf(file, "( %s . ) ",
1629 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1630 pvlim));
1631 }
b15aece3 1632 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
e9569a7a
GG
1633 if (SvUTF8(sv)) /* the 6? \x{....} */
1634 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
e6abe6d8 1635 PerlIO_printf(file, "\n");
57def98f
JH
1636 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1637 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
3967c732
JD
1638 }
1639 else
cea2e8a9 1640 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1641 }
e0bbf362 1642
3967c732 1643 if (type >= SVt_PVMG) {
0e4c4423 1644 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
61f9802b 1645 HV * const ost = SvOURSTASH(sv);
38cbaf55
RGS
1646 if (ost)
1647 do_hv_dump(level, file, " OURSTASH", ost);
0e4c4423
NC
1648 } else {
1649 if (SvMAGIC(sv))
8530ff28 1650 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
0e4c4423 1651 }
3967c732
JD
1652 if (SvSTASH(sv))
1653 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC
1654
1655 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
1656 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1657 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1658 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1659 }
3967c732 1660 }
e0bbf362
DM
1661
1662 /* Dump type-specific SV fields */
1663
3967c732 1664 switch (type) {
3967c732 1665 case SVt_PVAV:
57def98f 1666 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1667 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f
JH
1668 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1669 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732
JD
1670 }
1671 else
1672 PerlIO_putc(file, '\n');
57def98f
JH
1673 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1674 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
a3874608 1675 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
76f68e9b 1676 sv_setpvs(d, "");
11ca45c0
NC
1677 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1678 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP
1679 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1680 SvCUR(d) ? SvPVX_const(d) + 1 : "");
502c6561 1681 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
3967c732 1682 int count;
502c6561
NC
1683 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1684 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
3967c732 1685
57def98f 1686 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
2ef28da1 1687 if (elt)
3967c732
JD
1688 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1689 }
1690 }
1691 break;
1692 case SVt_PVHV:
57def98f 1693 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
1b95d04f 1694 if (HvARRAY(sv) && HvUSEDKEYS(sv)) {
3967c732
JD
1695 /* Show distribution of HEs in the ARRAY */
1696 int freq[200];
bb7a0f54 1697#define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
3967c732
JD
1698 int i;
1699 int max = 0;
1b95d04f 1700 U32 pow2 = 2, keys = HvUSEDKEYS(sv);
65202027 1701 NV theoret, sum = 0;
3967c732
JD
1702
1703 PerlIO_printf(file, " (");
1704 Zero(freq, FREQ_MAX + 1, int);
eb160463 1705 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL
1706 HE* h;
1707 int count = 0;
3967c732
JD
1708 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1709 count++;
1710 if (count > FREQ_MAX)
1711 count = FREQ_MAX;
1712 freq[count]++;
1713 if (max < count)
1714 max = count;
1715 }
1716 for (i = 0; i <= max; i++) {
1717 if (freq[i]) {
1718 PerlIO_printf(file, "%d%s:%d", i,
1719 (i == FREQ_MAX) ? "+" : "",
1720 freq[i]);
1721 if (i != max)
1722 PerlIO_printf(file, ", ");
1723 }
1724 }
1725 PerlIO_putc(file, ')');
b8fa94d8
MG
1726 /* The "quality" of a hash is defined as the total number of
1727 comparisons needed to access every element once, relative
1728 to the expected number needed for a random hash.
1729
1730 The total number of comparisons is equal to the sum of
e76cd0fa
AMS
1731 the squares of the number of entries in each bucket.
1732 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG
1733 value is
1734 n + n(n-1)/2k
1735 */
1736
3967c732
JD
1737 for (i = max; i > 0; i--) { /* Precision: count down. */
1738 sum += freq[i] * i * i;
1739 }
155aba94 1740 while ((keys = keys >> 1))
3967c732 1741 pow2 = pow2 << 1;
1b95d04f 1742 theoret = HvUSEDKEYS(sv);
b8fa94d8 1743 theoret += theoret * (theoret-1)/pow2;
3967c732 1744 PerlIO_putc(file, '\n');
6b4667fc 1745 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732
JD
1746 }
1747 PerlIO_putc(file, '\n');
1b95d04f 1748 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvUSEDKEYS(sv));
57def98f
JH
1749 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1750 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
bfcb3514
NC
1751 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1752 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
8d2f4536 1753 {
b9ac451d 1754 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536
NC
1755 if (mg && mg->mg_obj) {
1756 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1757 }
1758 }
bfcb3514 1759 {
b9ac451d 1760 const char * const hvname = HvNAME_get(sv);
bfcb3514
NC
1761 if (hvname)
1762 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1763 }
86f55936 1764 if (SvOOK(sv)) {
ad64d0ec 1765 AV * const backrefs
85fbaab2 1766 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 1767 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC
1768 if (HvAUX(sv)->xhv_name_count)
1769 Perl_dump_indent(aTHX_
7afc2217
FC
1770 level, file, " NAMECOUNT = %"IVdf"\n",
1771 (IV)HvAUX(sv)->xhv_name_count
67e04715 1772 );
15d9236d 1773 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC
1774 const I32 count = HvAUX(sv)->xhv_name_count;
1775 if (count) {
1776 SV * const names = newSVpvs_flags("", SVs_TEMP);
1777 /* The starting point is the first element if count is
1778 positive and the second element if count is negative. */
1779 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1780 + (count < 0 ? 1 : 0);
1781 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1782 + (count < 0 ? -count : count);
1783 while (hekp < endp) {
67e04715
FC
1784 if (*hekp) {
1785 sv_catpvs(names, ", \"");
ec3405c8 1786 sv_catpvn(names, HEK_KEY(*hekp), HEK_LEN(*hekp));
67e04715 1787 sv_catpvs(names, "\"");
ec3405c8
NC
1788 } else {
1789 /* This should never happen. */
1790 sv_catpvs(names, ", (null)");
67e04715 1791 }
ec3405c8
NC
1792 ++hekp;
1793 }
67e04715
FC
1794 Perl_dump_indent(aTHX_
1795 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1796 );
1797 }
1798 else
1799 Perl_dump_indent(aTHX_
1800 level, file, " ENAME = \"%s\"\n", HvENAME_get(sv)
1801 );
1802 }
86f55936
NC
1803 if (backrefs) {
1804 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1805 PTR2UV(backrefs));
ad64d0ec 1806 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC
1807 dumpops, pvlim);
1808 }
7d88e6c4
NC
1809 if (meta) {
1810 /* FIXME - mro_algs kflags can signal a UTF-8 name. */
1811 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%.*s\" (0x%"UVxf")\n",
1812 (int)meta->mro_which->length,
1813 meta->mro_which->name,
1814 PTR2UV(meta->mro_which));
1815 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1816 (UV)meta->cache_gen);
1817 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1818 (UV)meta->pkg_gen);
1819 if (meta->mro_linear_all) {
1820 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1821 PTR2UV(meta->mro_linear_all));
1822 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1823 dumpops, pvlim);
1824 }
1825 if (meta->mro_linear_current) {
1826 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1827 PTR2UV(meta->mro_linear_current));
1828 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1829 dumpops, pvlim);
1830 }
1831 if (meta->mro_nextmethod) {
1832 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1833 PTR2UV(meta->mro_nextmethod));
1834 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1835 dumpops, pvlim);
1836 }
1837 if (meta->isa) {
1838 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1839 PTR2UV(meta->isa));
1840 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1841 dumpops, pvlim);
1842 }
1843 }
86f55936 1844 }
b5698553 1845 if (nest < maxnest) {
cbab3169 1846 HV * const hv = MUTABLE_HV(sv);
b5698553
TH
1847 STRLEN i;
1848 HE *he;
cbab3169 1849
b5698553
TH
1850 if (HvARRAY(hv)) {
1851 int count = maxnest - nest;
1852 for (i=0; i <= HvMAX(hv); i++) {
1853 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1854 U32 hash;
1855 SV * keysv;
1856 const char * keypv;
1857 SV * elt;
cbab3169 1858 STRLEN len;
b5698553
TH
1859
1860 if (count-- <= 0) goto DONEHV;
1861
1862 hash = HeHASH(he);
1863 keysv = hv_iterkeysv(he);
1864 keypv = SvPV_const(keysv, len);
1865 elt = HeVAL(he);
cbab3169
FC
1866
1867 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1868 if (SvUTF8(keysv))
1869 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH
1870 if (HvEITER_get(hv) == he)
1871 PerlIO_printf(file, "[CURRENT] ");
cbab3169
FC
1872 if (HeKREHASH(he))
1873 PerlIO_printf(file, "[REHASH] ");
b5698553 1874 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
cbab3169 1875 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
3967c732 1876 }
b5698553
TH
1877 }
1878 DONEHV:;
1879 }
3967c732
JD
1880 }
1881 break;
e0bbf362 1882
3967c732 1883 case SVt_PVCV:
8fa6a409 1884 if (CvAUTOLOAD(sv)) {
cbf82dd0 1885 STRLEN len;
8fa6a409
FC
1886 const char *const name = SvPV_const(sv, len);
1887 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%.*s\"\n",
1888 (int) len, name);
1889 }
1890 if (SvPOK(sv)) {
cbf82dd0 1891 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
8fa6a409 1892 (int) CvPROTOLEN(sv), CvPROTO(sv));
cbf82dd0 1893 }
3967c732
JD
1894 /* FALL THROUGH */
1895 case SVt_PVFM:
1896 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC
1897 if (!CvISXSUB(sv)) {
1898 if (CvSTART(sv)) {
1899 Perl_dump_indent(aTHX_ level, file,
1900 " START = 0x%"UVxf" ===> %"IVdf"\n",
1901 PTR2UV(CvSTART(sv)),
1902 (IV)sequence_num(CvSTART(sv)));
1903 }
1904 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1905 PTR2UV(CvROOT(sv)));
1906 if (CvROOT(sv) && dumpops) {
1907 do_op_dump(level+1, file, CvROOT(sv));
1908 }
1909 } else {
126f53f3 1910 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 1911
d04ba589 1912 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099
NC
1913
1914 if (constant) {
1915 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1916 " (CONST SV)\n",
1917 PTR2UV(CvXSUBANY(sv).any_ptr));
1918 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1919 pvlim);
1920 } else {
1921 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1922 (IV)CvXSUBANY(sv).any_i32);
1923 }
1924 }
3967c732 1925 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1926 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
5129b2ca
NC
1927 if (type == SVt_PVCV)
1928 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 1929 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 1930 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
3967c732 1931 if (type == SVt_PVFM)
57def98f
JH
1932 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1933 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
dd2155a4
DM
1934 if (nest < maxnest) {
1935 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
3967c732
JD
1936 }
1937 {
b9ac451d 1938 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 1939 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 1940 PTR2UV(outside),
cf2093f6
JH
1941 (!outside ? "null"
1942 : CvANON(outside) ? "ANON"
1943 : (outside == PL_main_cv) ? "MAIN"
1944 : CvUNIQUE(outside) ? "UNIQUE"
1945 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
3967c732
JD
1946 }
1947 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
ad64d0ec 1948 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 1949 break;
e0bbf362 1950
926fc7b6
DM
1951 case SVt_PVGV:
1952 case SVt_PVLV:
b9ac451d
AL
1953 if (type == SVt_PVLV) {
1954 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1955 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1956 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1957 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
83f78d1a 1958 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
b9ac451d
AL
1959 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1960 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1961 dumpops, pvlim);
1962 }
926fc7b6
DM
1963 if (!isGV_with_GP(sv))
1964 break;
cea2e8a9 1965 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
57def98f 1966 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 1967 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
57def98f 1968 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c
GS
1969 if (!GvGP(sv))
1970 break;
57def98f
JH
1971 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1972 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1973 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1974 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1975 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1976 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1977 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1978 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
57def98f 1979 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 1980 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
e39917cc 1981 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
3967c732
JD
1982 do_gv_dump (level, file, " EGV", GvEGV(sv));
1983 break;
1984 case SVt_PVIO:
57def98f
JH
1985 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1986 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1987 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1988 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1989 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1990 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1991 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 1992 if (IoTOP_NAME(sv))
cea2e8a9 1993 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC
1994 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1995 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1996 else {
1997 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1998 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC
1999 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2000 maxnest, dumpops, pvlim);
9ba1f565
NC
2001 }
2002 /* Source filters hide things that are not GVs in these three, so let's
2003 be careful out there. */
27533608 2004 if (IoFMT_NAME(sv))
cea2e8a9 2005 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC
2006 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2007 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2008 else {
2009 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2010 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC
2011 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2012 maxnest, dumpops, pvlim);
9ba1f565 2013 }
27533608 2014 if (IoBOTTOM_NAME(sv))
cea2e8a9 2015 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC
2016 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2017 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2018 else {
2019 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2020 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC
2021 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2022 maxnest, dumpops, pvlim);
9ba1f565 2023 }
27533608 2024 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2025 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2026 else
cea2e8a9 2027 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 2028 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732 2029 break;
206ee256 2030 case SVt_REGEXP:
d63e6659
DM
2031 {
2032 struct regexp * const r = (struct regexp *)SvANY(sv);
2033 flags = RX_EXTFLAGS((REGEXP*)sv);
2034 sv_setpv(d,"");
2035 append_flags(d, flags, regexp_flags_names);
2036 if (*(SvEND(d) - 1) == ',') {
2037 SvCUR_set(d, SvCUR(d) - 1);
2038 SvPVX(d)[SvCUR(d)] = '\0';
2039 }
2040 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
2041 (UV)flags, SvPVX_const(d));
2042 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
2043 (UV)(r->intflags));
2044 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2045 (UV)(r->nparens));
2046 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2047 (UV)(r->lastparen));
2048 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2049 (UV)(r->lastcloseparen));
2050 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2051 (IV)(r->minlen));
2052 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2053 (IV)(r->minlenret));
2054 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2055 (UV)(r->gofs));
2056 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2057 (UV)(r->pre_prefix));
d63e6659
DM
2058 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2059 (IV)(r->sublen));
2060 if (r->subbeg)
2061 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2062 PTR2UV(r->subbeg),
2063 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2064 else
2065 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
2066 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf"\n",
2067 PTR2UV(r->engine));
2068 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2069 PTR2UV(r->mother_re));
2070 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2071 PTR2UV(r->paren_names));
2072 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2073 PTR2UV(r->substrs));
2074 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2075 PTR2UV(r->pprivate));
2076 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2077 PTR2UV(r->offs));
d63c20f2
DM
2078 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2079 PTR2UV(r->qr_anoncv));
d63e6659
DM
2080#ifdef PERL_OLD_COPY_ON_WRITE
2081 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2082 PTR2UV(r->saved_copy));
2083#endif
2084 }
206ee256 2085 break;
3967c732 2086 }
cea89e20 2087 SvREFCNT_dec(d);
3967c732
JD
2088}
2089
2090void
864dbfa3 2091Perl_sv_dump(pTHX_ SV *sv)
3967c732 2092{
97aff369 2093 dVAR;
7918f24d
NC
2094
2095 PERL_ARGS_ASSERT_SV_DUMP;
2096
d1029faa
JP
2097 if (SvROK(sv))
2098 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2099 else
2100 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2101}
bd16a5f0
IZ
2102
2103int
2104Perl_runops_debug(pTHX)
2105{
97aff369 2106 dVAR;
bd16a5f0 2107 if (!PL_op) {
9b387841 2108 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ
2109 return 0;
2110 }
2111
9f3673fb 2112 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2113 do {
bd16a5f0 2114 if (PL_debug) {
b9ac451d 2115 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0
IZ
2116 PerlIO_printf(Perl_debug_log,
2117 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2118 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2119 PTR2UV(*PL_watchaddr));
d6721266
DM
2120 if (DEBUG_s_TEST_) {
2121 if (DEBUG_v_TEST_) {
2122 PerlIO_printf(Perl_debug_log, "\n");
2123 deb_stack_all();
2124 }
2125 else
2126 debstack();
2127 }
2128
2129
bd16a5f0
IZ
2130 if (DEBUG_t_TEST_) debop(PL_op);
2131 if (DEBUG_P_TEST_) debprof(PL_op);
2132 }
16c91539 2133 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2134 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
bd16a5f0
IZ
2135
2136 TAINT_NOT;
2137 return 0;
2138}
2139
2140I32
6867be6d 2141Perl_debop(pTHX_ const OP *o)
bd16a5f0 2142{
97aff369 2143 dVAR;
7918f24d
NC
2144
2145 PERL_ARGS_ASSERT_DEBOP;
2146
1045810a
IZ
2147 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2148 return 0;
2149
bd16a5f0
IZ
2150 Perl_deb(aTHX_ "%s", OP_NAME(o));
2151 switch (o->op_type) {
2152 case OP_CONST:
996c9baa 2153 case OP_HINTSEVAL:
6cefa69e 2154 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2155 * may not be active here, so check.
6cefa69e 2156 * Looks like only during compiling the pads are illegal.
7367e658 2157 */
6cefa69e
RU
2158#ifdef USE_ITHREADS
2159 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2160#endif
7367e658 2161 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ
2162 break;
2163 case OP_GVSV:
2164 case OP_GV:
2165 if (cGVOPo_gv) {
b9ac451d 2166 SV * const sv = newSV(0);
3b721df9 2167#ifdef PERL_MAD
84021b46 2168 /* FIXME - is this making unwarranted assumptions about the
3b721df9
NC
2169 UTF-8 cleanliness of the dump file handle? */
2170 SvUTF8_on(sv);
2171#endif
bd61b366 2172 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2173 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
bd16a5f0
IZ
2174 SvREFCNT_dec(sv);
2175 }
2176 else
2177 PerlIO_printf(Perl_debug_log, "(NULL)");
2178 break;
2179 case OP_PADSV:
2180 case OP_PADAV:
2181 case OP_PADHV:
a3b680e6 2182 {
bd16a5f0 2183 /* print the lexical's name */
b9ac451d 2184 CV * const cv = deb_curcv(cxstack_ix);
a3b680e6 2185 SV *sv;
bd16a5f0 2186 if (cv) {
b9ac451d 2187 AV * const padlist = CvPADLIST(cv);
502c6561 2188 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
bd16a5f0
IZ
2189 sv = *av_fetch(comppad, o->op_targ, FALSE);
2190 } else
a0714e2c 2191 sv = NULL;
bd16a5f0 2192 if (sv)
b9ac451d 2193 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
bd16a5f0 2194 else
b9ac451d 2195 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
a3b680e6 2196 }
bd16a5f0
IZ
2197 break;
2198 default:
091ab601 2199 break;
bd16a5f0
IZ
2200 }
2201 PerlIO_printf(Perl_debug_log, "\n");
2202 return 0;
2203}
2204
2205STATIC CV*
61f9802b 2206S_deb_curcv(pTHX_ const I32 ix)
bd16a5f0 2207{
97aff369 2208 dVAR;
b9ac451d 2209 const PERL_CONTEXT * const cx = &cxstack[ix];
bd16a5f0
IZ
2210 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2211 return cx->blk_sub.cv;
2212 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
676a678a 2213 return cx->blk_eval.cv;
bd16a5f0
IZ
2214 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2215 return PL_main_cv;
2216 else if (ix <= 0)
601f1833 2217 return NULL;
bd16a5f0
IZ
2218 else
2219 return deb_curcv(ix - 1);
2220}
2221
2222void
2223Perl_watch(pTHX_ char **addr)
2224{
97aff369 2225 dVAR;
7918f24d
NC
2226
2227 PERL_ARGS_ASSERT_WATCH;
2228
bd16a5f0
IZ
2229 PL_watchaddr = addr;
2230 PL_watchok = *addr;
2231 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2232 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2233}
2234
2235STATIC void
e1ec3a88 2236S_debprof(pTHX_ const OP *o)
bd16a5f0 2237{
97aff369 2238 dVAR;
7918f24d
NC
2239
2240 PERL_ARGS_ASSERT_DEBPROF;
2241
61f9802b 2242 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2243 return;
bd16a5f0 2244 if (!PL_profiledata)
a02a5408 2245 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ
2246 ++PL_profiledata[o->op_type];
2247}
2248
2249void
2250Perl_debprofdump(pTHX)
2251{
97aff369 2252 dVAR;
bd16a5f0
IZ
2253 unsigned i;
2254 if (!PL_profiledata)
2255 return;
2256 for (i = 0; i < MAXO; i++) {
2257 if (PL_profiledata[i])
2258 PerlIO_printf(Perl_debug_log,
2259 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2260 PL_op_name[i]);
2261 }
2262}
66610fdd 2263
3b721df9
NC
2264#ifdef PERL_MAD
2265/*
2266 * XML variants of most of the above routines
2267 */
2268
4136a0f7 2269STATIC void
3b721df9
NC
2270S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2271{
2272 va_list args;
7918f24d
NC
2273
2274 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2275
3b721df9
NC
2276 PerlIO_printf(file, "\n ");
2277 va_start(args, pat);
2278 xmldump_vindent(level, file, pat, &args);
2279 va_end(args);
2280}
2281
2282
2283void
2284Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2285{
2286 va_list args;
7918f24d 2287 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
3b721df9
NC
2288 va_start(args, pat);
2289 xmldump_vindent(level, file, pat, &args);
2290 va_end(args);
2291}
2292
2293void
2294Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2295{
7918f24d
NC
2296 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2297
3b721df9
NC
2298 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2299 PerlIO_vprintf(file, pat, *args);
2300}
2301
2302void
2303Perl_xmldump_all(pTHX)
2304{
f0e3f042
CS
2305 xmldump_all_perl(FALSE);
2306}
2307
2308void
0190d5ef 2309Perl_xmldump_all_perl(pTHX_ bool justperl PERL_UNUSED_DECL)
f0e3f042 2310{
3b721df9
NC
2311 PerlIO_setlinebuf(PL_xmlfp);
2312 if (PL_main_root)
2313 op_xmldump(PL_main_root);
0190d5ef
CS
2314 /* someday we might call this, when it outputs XML: */
2315 /* xmldump_packsubs_perl(PL_defstash, justperl); */
3b721df9
NC
2316 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2317 PerlIO_close(PL_xmlfp);
2318 PL_xmlfp = 0;
2319}
2320
2321void
2322Perl_xmldump_packsubs(pTHX_ const HV *stash)
2323{
28eb953d 2324 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
3ab0c9fa
NC
2325 xmldump_packsubs_perl(stash, FALSE);
2326}
2327
2328void
2329Perl_xmldump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
2330{
3b721df9
NC
2331 I32 i;
2332 HE *entry;
2333
28eb953d 2334 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL;
7918f24d 2335
3b721df9
NC
2336 if (!HvARRAY(stash))
2337 return;
2338 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2339 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
159b6efe 2340 GV *gv = MUTABLE_GV(HeVAL(entry));
3b721df9
NC
2341 HV *hv;
2342 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2343 continue;
2344 if (GvCVu(gv))
3ab0c9fa 2345 xmldump_sub_perl(gv, justperl);
3b721df9
NC
2346 if (GvFORM(gv))
2347 xmldump_form(gv);
2348 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2349 && (hv = GvHV(gv)) && hv != PL_defstash)
3ab0c9fa 2350 xmldump_packsubs_perl(hv, justperl); /* nested package */
3b721df9
NC
2351 }
2352 }
2353}
2354
2355void
2356Perl_xmldump_sub(pTHX_ const GV *gv)
2357{
28eb953d 2358 PERL_ARGS_ASSERT_XMLDUMP_SUB;
f0e3f042
CS
2359 xmldump_sub_perl(gv, FALSE);
2360}
2361
2362void
2363Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
2364{
2365 SV * sv;
3b721df9 2366
28eb953d 2367 PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL;
7918f24d 2368
f0e3f042
CS
2369 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
2370 return;
2371
2372 sv = sv_newmortal();
1a9a51d4 2373 gv_fullname3(sv, gv, NULL);
3b721df9
NC
2374 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2375 if (CvXSUB(GvCV(gv)))
2376 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2377 PTR2UV(CvXSUB(GvCV(gv))),
2378 (int)CvXSUBANY(GvCV(gv)).any_i32);
2379 else if (CvROOT(GvCV(gv)))
2380 op_xmldump(CvROOT(GvCV(gv)));
2381 else
2382 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2383}
2384
2385void
2386Perl_xmldump_form(pTHX_ const GV *gv)
2387{
61f9802b 2388 SV * const sv = sv_newmortal();
3b721df9 2389
7918f24d
NC
2390 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2391
1a9a51d4 2392 gv_fullname3(sv, gv, NULL);
3b721df9
NC
2393 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2394 if (CvROOT(GvFORM(gv)))
2395 op_xmldump(CvROOT(GvFORM(gv)));
2396 else
2397 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2398}
2399
2400void
2401Perl_xmldump_eval(pTHX)
2402{
2403 op_xmldump(PL_eval_root);
2404}
2405
2406char *
2407Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2408{
7918f24d 2409 PERL_ARGS_ASSERT_SV_CATXMLSV;
3b721df9
NC
2410 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2411}
2412
2413char *
9dcc53ea
Z
2414Perl_sv_catxmlpv(pTHX_ SV *dsv, const char *pv, int utf8)
2415{
2416 PERL_ARGS_ASSERT_SV_CATXMLPV;
2417 return sv_catxmlpvn(dsv, pv, strlen(pv), utf8);
2418}
2419
2420char *
20f84293 2421Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
3b721df9
NC
2422{
2423 unsigned int c;
61f9802b 2424 const char * const e = pv + len;
20f84293 2425 const char * const start = pv;
3b721df9
NC
2426 STRLEN dsvcur;
2427 STRLEN cl;
2428
7918f24d
NC
2429 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2430
76f68e9b 2431 sv_catpvs(dsv,"");
3b721df9
NC
2432 dsvcur = SvCUR(dsv); /* in case we have to restart */
2433
2434 retry:
2435 while (pv < e) {
2436 if (utf8) {
4b88fb76 2437 c = utf8_to_uvchr_buf((U8*)pv, (U8*)e, &cl);
3b721df9
NC
2438 if (cl == 0) {
2439 SvCUR(dsv) = dsvcur;
2440 pv = start;
2441 utf8 = 0;
2442 goto retry;
2443 }
2444 }
2445 else
2446 c = (*pv & 255);
2447
2448 switch (c) {
2449 case 0x00:
2450 case 0x01:
2451 case 0x02:
2452 case 0x03:
2453 case 0x04:
2454 case 0x05:
2455 case 0x06:
2456 case 0x07:
2457 case 0x08:
2458 case 0x0b:
2459 case 0x0c:
2460 case 0x0e:
2461 case 0x0f:
2462 case 0x10:
2463 case 0x11:
2464 case 0x12:
2465 case 0x13:
2466 case 0x14:
2467 case 0x15:
2468 case 0x16:
2469 case 0x17:
2470 case 0x18:
2471 case 0x19:
2472 case 0x1a:
2473 case 0x1b:
2474 case 0x1c:
2475 case 0x1d:
2476 case 0x1e:
2477 case 0x1f:
2478 case 0x7f:
2479 case 0x80:
2480 case 0x81:
2481 case 0x82:
2482 case 0x83:
2483 case 0x84:
2484 case 0x86:
2485 case 0x87:
2486 case 0x88:
2487 case 0x89:
2488 case 0x90:
2489 case 0x91:
2490 case 0x92:
2491 case 0x93:
2492 case 0x94:
2493 case 0x95:
2494 case 0x96:
2495 case 0x97:
2496 case 0x98:
2497 case 0x99:
2498 case 0x9a:
2499 case 0x9b:
2500 case 0x9c:
2501 case 0x9d:
2502 case 0x9e:
2503 case 0x9f:
2504 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2505 break;
2506 case '<':
f3a2811a 2507 sv_catpvs(dsv, "&lt;");
3b721df9
NC
2508 break;
2509 case '>':
f3a2811a 2510 sv_catpvs(dsv, "&gt;");
3b721df9
NC
2511 break;
2512 case '&':
f3a2811a 2513 sv_catpvs(dsv, "&amp;");
3b721df9
NC
2514 break;
2515 case '"':
49de0815 2516 sv_catpvs(dsv, "&#34;");
3b721df9
NC
2517 break;
2518 default:
2519 if (c < 0xD800) {
2520 if (c < 32 || c > 127) {
2521 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2522 }
2523 else {
5e7aa789
NC
2524 const char string = (char) c;
2525 sv_catpvn(dsv, &string, 1);
3b721df9
NC
2526 }
2527 break;
2528 }
2529 if ((c >= 0xD800 && c <= 0xDB7F) ||
2530 (c >= 0xDC00 && c <= 0xDFFF) ||
2531 (c >= 0xFFF0 && c <= 0xFFFF) ||
2532 c > 0x10ffff)
2533 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2534 else
2535 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2536 }
2537
2538 if (utf8)
2539 pv += UTF8SKIP(pv);
2540 else
2541 pv++;
2542 }
2543
2544 return SvPVX(dsv);
2545}
2546
2547char *
2548Perl_sv_xmlpeek(pTHX_ SV *sv)
2549{
61f9802b 2550 SV * const t = sv_newmortal();
3b721df9
NC
2551 STRLEN n_a;
2552 int unref = 0;
2553
7918f24d
NC
2554 PERL_ARGS_ASSERT_SV_XMLPEEK;
2555
3b721df9 2556 sv_utf8_upgrade(t);
76f68e9b 2557 sv_setpvs(t, "");
3b721df9
NC
2558 /* retry: */
2559 if (!sv) {
2560 sv_catpv(t, "VOID=\"\"");
2561 goto finish;
2562 }
ad64d0ec 2563 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
3b721df9
NC
2564 sv_catpv(t, "WILD=\"\"");
2565 goto finish;
2566 }
2567 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2568 if (sv == &PL_sv_undef) {
2569 sv_catpv(t, "SV_UNDEF=\"1\"");
2570 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2571 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2572 SvREADONLY(sv))
2573 goto finish;
2574 }
2575 else if (sv == &PL_sv_no) {
2576 sv_catpv(t, "SV_NO=\"1\"");
2577 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2578 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2579 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2580 SVp_POK|SVp_NOK)) &&
2581 SvCUR(sv) == 0 &&
2582 SvNVX(sv) == 0.0)
2583 goto finish;
2584 }
2585 else if (sv == &PL_sv_yes) {
2586 sv_catpv(t, "SV_YES=\"1\"");
2587 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2588 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2589 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2590 SVp_POK|SVp_NOK)) &&
2591 SvCUR(sv) == 1 &&
2592 SvPVX(sv) && *SvPVX(sv) == '1' &&
2593 SvNVX(sv) == 1.0)
2594 goto finish;
2595 }
2596 else {
2597 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2598 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2599 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2600 SvREADONLY(sv))
2601 goto finish;
2602 }
2603 sv_catpv(t, " XXX=\"\" ");
2604 }
2605 else if (SvREFCNT(sv) == 0) {
2606 sv_catpv(t, " refcnt=\"0\"");
2607 unref++;
2608 }
2609 else if (DEBUG_R_TEST_) {
2610 int is_tmp = 0;
2611 I32 ix;
2612 /* is this SV on the tmps stack? */
2613 for (ix=PL_tmps_ix; ix>=0; ix--) {
2614 if (PL_tmps_stack[ix] == sv) {
2615 is_tmp = 1;
2616 break;
2617 }
2618 }
2619 if (SvREFCNT(sv) > 1)
2620 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2621 is_tmp ? "T" : "");
2622 else if (is_tmp)
2623 sv_catpv(t, " DRT=\"<T>\"");
2624 }
2625
2626 if (SvROK(sv)) {
2627 sv_catpv(t, " ROK=\"\"");
2628 }
2629 switch (SvTYPE(sv)) {
2630 default:
2631 sv_catpv(t, " FREED=\"1\"");
2632 goto finish;
2633
2634 case SVt_NULL:
2635 sv_catpv(t, " UNDEF=\"1\"");
2636 goto finish;
2637 case SVt_IV:
2638 sv_catpv(t, " IV=\"");
2639 break;
2640 case SVt_NV:
2641 sv_catpv(t, " NV=\"");
2642 break;
3b721df9
NC
2643 case SVt_PV:
2644 sv_catpv(t, " PV=\"");
2645 break;
2646 case SVt_PVIV:
2647 sv_catpv(t, " PVIV=\"");
2648 break;
2649 case SVt_PVNV:
2650 sv_catpv(t, " PVNV=\"");
2651 break;
2652 case SVt_PVMG:
2653 sv_catpv(t, " PVMG=\"");
2654 break;
2655 case SVt_PVLV:
2656 sv_catpv(t, " PVLV=\"");
2657 break;
2658 case SVt_PVAV:
2659 sv_catpv(t, " AV=\"");
2660 break;
2661 case SVt_PVHV:
2662 sv_catpv(t, " HV=\"");
2663 break;
2664 case SVt_PVCV:
2665 if (CvGV(sv))
2666 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2667 else
2668 sv_catpv(t, " CV=\"()\"");
2669 goto finish;
2670 case SVt_PVGV:
2671 sv_catpv(t, " GV=\"");
2672 break;
cecf5685
NC
2673 case SVt_BIND:
2674 sv_catpv(t, " BIND=\"");
3b721df9 2675 break;
d914baab 2676 case SVt_REGEXP:
8619e557 2677 sv_catpv(t, " REGEXP=\"");
4df7f6af 2678 break;
3b721df9
NC
2679 case SVt_PVFM:
2680 sv_catpv(t, " FM=\"");
2681 break;
2682 case SVt_PVIO:
2683 sv_catpv(t, " IO=\"");
2684 break;
2685 }
2686
2687 if (SvPOKp(sv)) {
2688 if (SvPVX(sv)) {
2689 sv_catxmlsv(t, sv);
2690 }
2691 }
2692 else if (SvNOKp(sv)) {
2693 STORE_NUMERIC_LOCAL_SET_STANDARD();
2694 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2695 RESTORE_NUMERIC_LOCAL();
2696 }
2697 else if (SvIOKp(sv)) {
2698 if (SvIsUV(sv))
2699 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2700 else
2701 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2702 }
2703 else
2704 sv_catpv(t, "");
2705 sv_catpv(t, "\"");
2706
2707 finish:
61f9802b
AL
2708 while (unref--)
2709 sv_catpv(t, ")");
3b721df9
NC
2710 return SvPV(t, n_a);
2711}
2712
2713void
2714Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2715{
7918f24d
NC
2716 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2717
3b721df9
NC
2718 if (!pm) {
2719 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2720 return;
2721 }
2722 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2723 level++;
2724 if (PM_GETRE(pm)) {
d914baab 2725 REGEXP *const r = PM_GETRE(pm);
643e696a 2726 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
ad64d0ec 2727 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
3b721df9
NC
2728 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2729 SvPVX(tmpsv));
2730 SvREFCNT_dec(tmpsv);
2731 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2732 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2733 }
2734 else
2735 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
d914baab 2736 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
3df43ef7 2737 SV * const tmpsv = pm_description(pm);
3b721df9
NC
2738 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2739 SvREFCNT_dec(tmpsv);
2740 }
2741
2742 level--;
20e98b0f 2743 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
3b721df9
NC
2744 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2745 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
20e98b0f 2746 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
3b721df9
NC
2747 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2748 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2749 }
2750 else
2751 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2752}
2753
2754void
2755Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2756{
2757 do_pmop_xmldump(0, PL_xmlfp, pm);
2758}
2759
2760void
2761Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2762{
2763 UV seq;
2764 int contents = 0;
7918f24d
NC
2765
2766 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2767
3b721df9
NC
2768 if (!o)
2769 return;
3b721df9
NC
2770 seq = sequence_num(o);
2771 Perl_xmldump_indent(aTHX_ level, file,
2772 "<op_%s seq=\"%"UVuf" -> ",
2773 OP_NAME(o),
2774 seq);
2775 level++;
2776 if (o->op_next)
2777 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2778 sequence_num(o->op_next));
2779 else
2780 PerlIO_printf(file, "DONE\"");
2781
2782 if (o->op_targ) {
2783 if (o->op_type == OP_NULL)
2784 {
2785 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2786 if (o->op_targ == OP_NEXTSTATE)
2787 {
2788 if (CopLINE(cCOPo))
f5992bc4 2789 PerlIO_printf(file, " line=\"%"UVuf"\"",
3b721df9
NC
2790 (UV)CopLINE(cCOPo));
2791 if (CopSTASHPV(cCOPo))
2792 PerlIO_printf(file, " package=\"%s\"",
2793 CopSTASHPV(cCOPo));
4b65a919 2794 if (CopLABEL(cCOPo))
3b721df9 2795 PerlIO_printf(file, " label=\"%s\"",
4b65a919 2796 CopLABEL(cCOPo));
3b721df9
NC
2797 }
2798 }
2799 else
2800 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2801 }
2802#ifdef DUMPADDR
2803 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2804#endif
2805 if (o->op_flags) {
76f68e9b 2806 SV * const tmpsv = newSVpvs("");
3b721df9
NC
2807 switch (o->op_flags & OPf_WANT) {
2808 case OPf_WANT_VOID:
2809 sv_catpv(tmpsv, ",VOID");
2810 break;
2811 case OPf_WANT_SCALAR:
2812 sv_catpv(tmpsv, ",SCALAR");
2813 break;
2814 case OPf_WANT_LIST:
2815 sv_catpv(tmpsv, ",LIST");
2816 break;
2817 default:
2818 sv_catpv(tmpsv, ",UNKNOWN");
2819 break;
2820 }
2821 if (o->op_flags & OPf_KIDS)
2822 sv_catpv(tmpsv, ",KIDS");
2823 if (o->op_flags & OPf_PARENS)
2824 sv_catpv(tmpsv, ",PARENS");
2825 if (o->op_flags & OPf_STACKED)
2826 sv_catpv(tmpsv, ",STACKED");
2827 if (o->op_flags & OPf_REF)
2828 sv_catpv(tmpsv, ",REF");
2829 if (o->op_flags & OPf_MOD)
2830 sv_catpv(tmpsv, ",MOD");
2831 if (o->op_flags & OPf_SPECIAL)
2832 sv_catpv(tmpsv, ",SPECIAL");
2833 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2834 SvREFCNT_dec(tmpsv);
2835 }
2836 if (o->op_private) {
76f68e9b 2837 SV * const tmpsv = newSVpvs("");
3b721df9
NC
2838 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2839 if (o->op_private & OPpTARGET_MY)
2840 sv_catpv(tmpsv, ",TARGET_MY");
2841 }
2842 else if (o->op_type == OP_LEAVESUB ||
2843 o->op_type == OP_LEAVE ||
2844 o->op_type == OP_LEAVESUBLV ||
2845 o->op_type == OP_LEAVEWRITE) {
2846 if (o->op_private & OPpREFCOUNTED)
2847 sv_catpv(tmpsv, ",REFCOUNTED");
2848 }
2849 else if (o->op_type == OP_AASSIGN) {
2850 if (o->op_private & OPpASSIGN_COMMON)
2851 sv_catpv(tmpsv, ",COMMON");
2852 }
2853 else if (o->op_type == OP_SASSIGN) {
2854 if (o->op_private & OPpASSIGN_BACKWARDS)
2855 sv_catpv(tmpsv, ",BACKWARDS");
2856 }
2857 else if (o->op_type == OP_TRANS) {
2858 if (o->op_private & OPpTRANS_SQUASH)
2859 sv_catpv(tmpsv, ",SQUASH");
2860 if (o->op_private & OPpTRANS_DELETE)
2861 sv_catpv(tmpsv, ",DELETE");
2862 if (o->op_private & OPpTRANS_COMPLEMENT)
2863 sv_catpv(tmpsv, ",COMPLEMENT");
2864 if (o->op_private & OPpTRANS_IDENTICAL)
2865 sv_catpv(tmpsv, ",IDENTICAL");
2866 if (o->op_private & OPpTRANS_GROWS)
2867 sv_catpv(tmpsv, ",GROWS");
2868 }
2869 else if (o->op_type == OP_REPEAT) {
2870 if (o->op_private & OPpREPEAT_DOLIST)
2871 sv_catpv(tmpsv, ",DOLIST");
2872 }
2873 else if (o->op_type == OP_ENTERSUB ||
2874 o->op_type == OP_RV2SV ||
2875 o->op_type == OP_GVSV ||
2876 o->op_type == OP_RV2AV ||
2877 o->op_type == OP_RV2HV ||
2878 o->op_type == OP_RV2GV ||
2879 o->op_type == OP_AELEM ||
2880 o->op_type == OP_HELEM )
2881 {
2882 if (o->op_type == OP_ENTERSUB) {
2883 if (o->op_private & OPpENTERSUB_AMPER)
2884 sv_catpv(tmpsv, ",AMPER");
2885 if (o->op_private & OPpENTERSUB_DB)
2886 sv_catpv(tmpsv, ",DB");
2887 if (o->op_private & OPpENTERSUB_HASTARG)
2888 sv_catpv(tmpsv, ",HASTARG");
2889 if (o->op_private & OPpENTERSUB_NOPAREN)
2890 sv_catpv(tmpsv, ",NOPAREN");
2891 if (o->op_private & OPpENTERSUB_INARGS)
2892 sv_catpv(tmpsv, ",INARGS");
3b721df9
NC
2893 }
2894 else {
2895 switch (o->op_private & OPpDEREF) {
2896 case OPpDEREF_SV:
2897 sv_catpv(tmpsv, ",SV");
2898 break;
2899 case OPpDEREF_AV:
2900 sv_catpv(tmpsv, ",AV");
2901 break;
2902 case OPpDEREF_HV:
2903 sv_catpv(tmpsv, ",HV");
2904 break;
2905 }
2906 if (o->op_private & OPpMAYBE_LVSUB)
2907 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2908 }
2909 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2910 if (o->op_private & OPpLVAL_DEFER)
2911 sv_catpv(tmpsv, ",LVAL_DEFER");
2912 }
2913 else {
2914 if (o->op_private & HINT_STRICT_REFS)
2915 sv_catpv(tmpsv, ",STRICT_REFS");
2916 if (o->op_private & OPpOUR_INTRO)
2917 sv_catpv(tmpsv, ",OUR_INTRO");
2918 }
2919 }
2920 else if (o->op_type == OP_CONST) {
2921 if (o->op_private & OPpCONST_BARE)
2922 sv_catpv(tmpsv, ",BARE");
2923 if (o->op_private & OPpCONST_STRICT)
2924 sv_catpv(tmpsv, ",STRICT");
3b721df9
NC
2925 if (o->op_private & OPpCONST_ENTERED)
2926 sv_catpv(tmpsv, ",ENTERED");
cc2ebcd7
FC
2927 if (o->op_private & OPpCONST_FOLDED)
2928 sv_catpv(tmpsv, ",FOLDED");
3b721df9
NC
2929 }
2930 else if (o->op_type == OP_FLIP) {
2931 if (o->op_private & OPpFLIP_LINENUM)
2932 sv_catpv(tmpsv, ",LINENUM");
2933 }
2934 else if (o->op_type == OP_FLOP) {
2935 if (o->op_private & OPpFLIP_LINENUM)
2936 sv_catpv(tmpsv, ",LINENUM");
2937 }
2938 else if (o->op_type == OP_RV2CV) {
2939 if (o->op_private & OPpLVAL_INTRO)
2940 sv_catpv(tmpsv, ",INTRO");
2941 }
2942 else if (o->op_type == OP_GV) {
2943 if (o->op_private & OPpEARLY_CV)
2944 sv_catpv(tmpsv, ",EARLY_CV");
2945 }
2946 else if (o->op_type == OP_LIST) {
2947 if (o->op_private & OPpLIST_GUESSED)
2948 sv_catpv(tmpsv, ",GUESSED");
2949 }
2950 else if (o->op_type == OP_DELETE) {
2951 if (o->op_private & OPpSLICE)
2952 sv_catpv(tmpsv, ",SLICE");
2953 }
2954 else if (o->op_type == OP_EXISTS) {
2955 if (o->op_private & OPpEXISTS_SUB)
2956 sv_catpv(tmpsv, ",EXISTS_SUB");
2957 }
2958 else if (o->op_type == OP_SORT) {
2959 if (o->op_private & OPpSORT_NUMERIC)
2960 sv_catpv(tmpsv, ",NUMERIC");
2961 if (o->op_private & OPpSORT_INTEGER)
2962 sv_catpv(tmpsv, ",INTEGER");
2963 if (o->op_private & OPpSORT_REVERSE)
2964 sv_catpv(tmpsv, ",REVERSE");
2965 }
3b721df9
NC
2966 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2967 if (o->op_private & OPpOPEN_IN_RAW)
2968 sv_catpv(tmpsv, ",IN_RAW");
2969 if (o->op_private & OPpOPEN_IN_CRLF)
2970 sv_catpv(tmpsv, ",IN_CRLF");
2971 if (o->op_private & OPpOPEN_OUT_RAW)
2972 sv_catpv(tmpsv, ",OUT_RAW");
2973 if (o->op_private & OPpOPEN_OUT_CRLF)
2974 sv_catpv(tmpsv, ",OUT_CRLF");
2975 }
2976 else if (o->op_type == OP_EXIT) {
2977 if (o->op_private & OPpEXIT_VMSISH)
2978 sv_catpv(tmpsv, ",EXIT_VMSISH");
2979 if (o->op_private & OPpHUSH_VMSISH)
2980 sv_catpv(tmpsv, ",HUSH_VMSISH");
2981 }
2982 else if (o->op_type == OP_DIE) {
2983 if (o->op_private & OPpHUSH_VMSISH)
2984 sv_catpv(tmpsv, ",HUSH_VMSISH");
2985 }
ef69c8fc 2986 else if (PL_check[o->op_type] != Perl_ck_ftst) {
6ecf81d6 2987 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
3b721df9
NC
2988 sv_catpv(tmpsv, ",FT_ACCESS");
2989 if (o->op_private & OPpFT_STACKED)
2990 sv_catpv(tmpsv, ",FT_STACKED");
2991 }
2992 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2993 sv_catpv(tmpsv, ",INTRO");
2994 if (SvCUR(tmpsv))
2995 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2996 SvREFCNT_dec(tmpsv);
2997 }
2998
2999 switch (o->op_type) {
3000 case OP_AELEMFAST:
3001 if (o->op_flags & OPf_SPECIAL) {
3002 break;
3003 }
3004 case OP_GVSV:
3005 case OP_GV:
3006#ifdef USE_ITHREADS
3007 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
3008#else
3009 if (cSVOPo->op_sv) {
d914baab
NC
3010 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
3011 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3b721df9
NC
3012 char *s;
3013 STRLEN len;
3014 ENTER;
3015 SAVEFREESV(tmpsv1);
3016 SAVEFREESV(tmpsv2);
159b6efe 3017 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3b721df9
NC
3018 s = SvPV(tmpsv1,len);
3019 sv_catxmlpvn(tmpsv2, s, len, 1);
3020 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
3021 LEAVE;
3022 }
3023 else
3024 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
3025#endif
3026 break;
3027 case OP_CONST:
996c9baa 3028 case OP_HINTSEVAL:
3b721df9
NC
3029 case OP_METHOD_NAMED:
3030#ifndef USE_ITHREADS
3031 /* with ITHREADS, consts are stored in the pad, and the right pad
3032 * may not be active here, so skip */
3033 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
3034#endif
3035 break;
3036 case OP_ANONCODE:
3037 if (!contents) {
3038 contents = 1;
3039 PerlIO_printf(file, ">\n");
3040 }
3041 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
3042 break;
3b721df9
NC
3043 case OP_NEXTSTATE:
3044 case OP_DBSTATE:
3045 if (CopLINE(cCOPo))
f5992bc4 3046 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3b721df9
NC
3047 (UV)CopLINE(cCOPo));
3048 if (CopSTASHPV(cCOPo))
3049 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
3050 CopSTASHPV(cCOPo));
4b65a919 3051 if (CopLABEL(cCOPo))
3b721df9 3052 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
4b65a919 3053 CopLABEL(cCOPo));
3b721df9
NC
3054 break;
3055 case OP_ENTERLOOP:
3056 S_xmldump_attr(aTHX_ level, file, "redo=\"");
3057 if (cLOOPo->op_redoop)
3058 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
3059 else
3060 PerlIO_printf(file, "DONE\"");
3061 S_xmldump_attr(aTHX_ level, file, "next=\"");
3062 if (cLOOPo->op_nextop)
3063 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
3064 else
3065 PerlIO_printf(file, "DONE\"");
3066 S_xmldump_attr(aTHX_ level, file, "last=\"");
3067 if (cLOOPo->op_lastop)
3068 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
3069 else
3070 PerlIO_printf(file, "DONE\"");
3071 break;
3072 case OP_COND_EXPR:
3073 case OP_RANGE:
3074 case OP_MAPWHILE:
3075 case OP_GREPWHILE:
3076 case OP_OR:
3077 case OP_AND:
3078 S_xmldump_attr(aTHX_ level, file, "other=\"");
3079 if (cLOGOPo->op_other)
3080 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
3081 else
3082 PerlIO_printf(file, "DONE\"");
3083 break;
3084 case OP_LEAVE:
3085 case OP_LEAVEEVAL:
3086 case OP_LEAVESUB:
3087 case OP_LEAVESUBLV:
3088 case OP_LEAVEWRITE:
3089 case OP_SCOPE:
3090 if (o->op_private & OPpREFCOUNTED)
3091 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
3092 break;
3093 default:
3094 break;
3095 }
3096
3097 if (PL_madskills && o->op_madprop) {
fb2b694a 3098 char prevkey = '\0';
d914baab 3099 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
20f84293 3100 const MADPROP* mp = o->op_madprop;
61f9802b 3101
3b721df9
NC
3102 if (!contents) {
3103 contents = 1;
3104 PerlIO_printf(file, ">\n");
3105 }
3106 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
3107 level++;
3108 while (mp) {
3109 char tmp = mp->mad_key;
76f68e9b 3110 sv_setpvs(tmpsv,"\"");
3b721df9
NC
3111 if (tmp)
3112 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
fb2b694a
GG
3113 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
3114 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
3115 else
3116 prevkey = tmp;
3b721df9
NC
3117 sv_catpv(tmpsv, "\"");
3118 switch (mp->mad_type) {
3119 case MAD_NULL:
3120 sv_catpv(tmpsv, "NULL");
3121 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
3122 break;
3123 case MAD_PV:
3124 sv_catpv(tmpsv, " val=\"");
3125 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
3126 sv_catpv(tmpsv, "\"");
3127 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
3128 break;
3129 case MAD_SV:
3130 sv_catpv(tmpsv, " val=\"");
ad64d0ec 3131 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3b721df9
NC
3132 sv_catpv(tmpsv, "\"");
3133 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
3134 break;
3135 case MAD_OP:
3136 if ((OP*)mp->mad_val) {
3137 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
3138 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
3139 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
3140 }
3141 break;
3142 default:
3143 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
3144 break;
3145 }
3146 mp = mp->mad_next;
3147 }
3148 level--;
3149 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
3150
3151 SvREFCNT_dec(tmpsv);
3152 }
3153
3154 switch (o->op_type) {
3155 case OP_PUSHRE:
3156 case OP_MATCH:
3157 case OP_QR:
3158 case OP_SUBST:
3159 if (!contents) {
3160 contents = 1;
3161 PerlIO_printf(file, ">\n");
3162 }
3163 do_pmop_xmldump(level, file, cPMOPo);
3164 break;
3165 default:
3166 break;
3167 }
3168
3169 if (o->op_flags & OPf_KIDS) {
3170 OP *kid;
3171 if (!contents) {
3172 contents = 1;
3173 PerlIO_printf(file, ">\n");
3174 }
3175 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
3176 do_op_xmldump(level, file, kid);
3177 }
3178
3179 if (contents)
3180 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3181 else
3182 PerlIO_printf(file, " />\n");
3183}
3184
3185void
3186Perl_op_xmldump(pTHX_ const OP *o)
3187{
7918f24d
NC
3188 PERL_ARGS_ASSERT_OP_XMLDUMP;
3189
3b721df9
NC
3190 do_op_xmldump(0, PL_xmlfp, o);
3191}
3192#endif
3193
66610fdd
RGS
3194/*
3195 * Local variables:
3196 * c-indentation-style: bsd
3197 * c-basic-offset: 4
14d04a33 3198 * indent-tabs-mode: nil
66610fdd
RGS
3199 * End:
3200 *
14d04a33 3201 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3202 */