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