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