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