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