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