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