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