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