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