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