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