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