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
Updating ExtUtils-ParseXS to 2.20
[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
5988ef3d 1043 if ( ! (PL_op->op_flags & OPf_SPECIAL)) { /* not lexical */
38c076c7 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,");
7dafbf52 1480 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,");
3967c732
JD		 1481 break;
1482 case SVt_PVHV:
1483 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
1484 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
19692e8d 1485 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,");
afce8e55 1486 if (HvREHASH(sv)) sv_catpv(d, "REHASH,");
9660f481 1487 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,");
3967c732 1488 break;
926fc7b6
DM		 1489 case SVt_PVGV:
1490 case SVt_PVLV:
1491 if (isGV_with_GP(sv)) {
1492 if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
1493 if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
926fc7b6
DM		 1494 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
1495 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,");
1496 }
926fc7b6 1497 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD		 1498 sv_catpv(d, "IMPORT");
1499 if (GvIMPORTED(sv) == GVf_IMPORTED)
1500 sv_catpv(d, "ALL,");
1501 else {
1502 sv_catpv(d, "(");
1503 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
1504 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
1505 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
1506 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
1507 sv_catpv(d, " ),");
1508 }
1509 }
cecf5685
NC		 1510 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1511 if (SvVALID(sv)) sv_catpv(d, "VALID,");
addd1794 1512 /* FALL THROUGH */
25da4f38 1513 default:
e604303a 1514 evaled_or_uv:
25da4f38 1515 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
69c678eb 1516 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1517 break;
addd1794 1518 case SVt_PVMG:
00b1698f 1519 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
e604303a 1520 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
2e94196c 1521 /* FALL THROUGH */
e604303a
NC		 1522 case SVt_PVNV:
1523 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1524 goto evaled_or_uv;
11ca45c0
NC		 1525 case SVt_PVAV:
1526 break;
3967c732 1527 }
86f0d186
NC		 1528 /* SVphv_SHAREKEYS is also 0x20000000 */
1529 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1530 sv_catpv(d, "UTF8");
3967c732 1531
b162af07
SP		 1532 if (*(SvEND(d) - 1) == ',') {
1533 SvCUR_set(d, SvCUR(d) - 1);
1534 SvPVX(d)[SvCUR(d)] = '\0';
1535 }
3967c732 1536 sv_catpv(d, ")");
b15aece3 1537 s = SvPVX_const(d);
3967c732 1538
fd0854ff
DM		 1539#ifdef DEBUG_LEAKING_SCALARS
1540 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n",
1541 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1542 sv->sv_debug_line,
1543 sv->sv_debug_inpad ? "for" : "by",
1544 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
1545 sv->sv_debug_cloned ? " (cloned)" : "");
1546#endif
cea2e8a9 1547 Perl_dump_indent(aTHX_ level, file, "SV = ");
5357ca29
NC		 1548 if (type < SVt_LAST) {
1549 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1550
1551 if (type == SVt_NULL) {
1552 SvREFCNT_dec(d);
1553 return;
1554 }
1555 } else {
faccc32b 1556 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
cea89e20 1557 SvREFCNT_dec(d);
3967c732
JD		 1558 return;
1559 }
27bd069f 1560 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
30ec677d 1561 && type != SVt_PVCV && !isGV_with_GP(sv) && type != SVt_PVFM)
4df7f6af 1562 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1563 if (SvIsUV(sv)
f8c7b90f 1564#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC		 1565 || SvIsCOW(sv)
1566#endif
1567 )
57def98f 1568 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1569 else
57def98f 1570 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
f8c7b90f 1571#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC		 1572 if (SvIsCOW_shared_hash(sv))
1573 PerlIO_printf(file, " (HASH)");
1574 else if (SvIsCOW_normal(sv))
1575 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1576#endif
3967c732
JD		 1577 PerlIO_putc(file, '\n');
1578 }
0e4c4423
NC		 1579 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) {
1580 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1581 (UV) COP_SEQ_RANGE_LOW(sv));
1582 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1583 (UV) COP_SEQ_RANGE_HIGH(sv));
1584 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1585 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1586 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1587 || type == SVt_NV) {
e54dc35b 1588 STORE_NUMERIC_LOCAL_SET_STANDARD();
57def98f 1589 /* %Vg doesn't work? --jhi */
cf2093f6 1590#ifdef USE_LONG_DOUBLE
2d4389e4 1591 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv));
cf2093f6 1592#else
cea2e8a9 1593 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
cf2093f6 1594#endif
e54dc35b 1595 RESTORE_NUMERIC_LOCAL();
3967c732
JD		 1596 }
1597 if (SvROK(sv)) {
57def98f 1598 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732
JD		 1599 if (nest < maxnest)
1600 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1601 }
cea89e20
JH		 1602 if (type < SVt_PV) {
1603 SvREFCNT_dec(d);
3967c732 1604 return;
cea89e20 1605 }
a49b46c6 1606 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) {
b15aece3 1607 if (SvPVX_const(sv)) {
69240efd 1608 STRLEN delta;
7a4bba22 1609 if (SvOOK(sv)) {
69240efd 1610 SvOOK_offset(sv, delta);
7a4bba22 1611 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
5186cc12 1612 (UV) delta);
69240efd
NC		 1613 } else {
1614 delta = 0;
7a4bba22 1615 }
b15aece3 1616 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv)));
7a4bba22
NC		 1617 if (SvOOK(sv)) {
1618 PerlIO_printf(file, "( %s . ) ",
1619 pv_display(d, SvPVX_const(sv) - delta, delta, 0,
1620 pvlim));
1621 }
b15aece3 1622 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim));
e9569a7a
GG		 1623 if (SvUTF8(sv)) /* the 6? \x{....} */
1624 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ));
e6abe6d8 1625 PerlIO_printf(file, "\n");
57def98f
JH		 1626 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
1627 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv));
3967c732
JD		 1628 }
1629 else
cea2e8a9 1630 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1631 }
f19b4ba9 1632 if (type == SVt_REGEXP) {
288b8c02 1633 /* FIXME dumping
f19b4ba9 1634 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
288b8c02
NC		 1635 PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
1636 */
f19b4ba9 1637 }
3967c732 1638 if (type >= SVt_PVMG) {
0e4c4423 1639 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
61f9802b 1640 HV * const ost = SvOURSTASH(sv);
38cbaf55
RGS		 1641 if (ost)
1642 do_hv_dump(level, file, " OURSTASH", ost);
0e4c4423
NC		 1643 } else {
1644 if (SvMAGIC(sv))
1645 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim);
1646 }
3967c732
JD		 1647 if (SvSTASH(sv))
1648 do_hv_dump(level, file, " STASH", SvSTASH(sv));
1649 }
1650 switch (type) {
3967c732 1651 case SVt_PVAV:
57def98f 1652 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1653 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f
JH		 1654 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1655 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732
JD		 1656 }
1657 else
1658 PerlIO_putc(file, '\n');
57def98f
JH		 1659 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1660 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
a3874608 1661 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
76f68e9b 1662 sv_setpvs(d, "");
11ca45c0
NC		 1663 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1664 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP		 1665 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1666 SvCUR(d) ? SvPVX_const(d) + 1 : "");
502c6561 1667 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) {
3967c732 1668 int count;
502c6561
NC		 1669 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) {
1670 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
3967c732 1671
57def98f 1672 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
2ef28da1 1673 if (elt)
3967c732
JD		 1674 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1675 }
1676 }
1677 break;
1678 case SVt_PVHV:
57def98f 1679 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
3967c732
JD		 1680 if (HvARRAY(sv) && HvKEYS(sv)) {
1681 /* Show distribution of HEs in the ARRAY */
1682 int freq[200];
bb7a0f54 1683#define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1))
3967c732
JD		 1684 int i;
1685 int max = 0;
1686 U32 pow2 = 2, keys = HvKEYS(sv);
65202027 1687 NV theoret, sum = 0;
3967c732
JD		 1688
1689 PerlIO_printf(file, " (");
1690 Zero(freq, FREQ_MAX + 1, int);
eb160463 1691 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL		 1692 HE* h;
1693 int count = 0;
3967c732
JD		 1694 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1695 count++;
1696 if (count > FREQ_MAX)
1697 count = FREQ_MAX;
1698 freq[count]++;
1699 if (max < count)
1700 max = count;
1701 }
1702 for (i = 0; i <= max; i++) {
1703 if (freq[i]) {
1704 PerlIO_printf(file, "%d%s:%d", i,
1705 (i == FREQ_MAX) ? "+" : "",
1706 freq[i]);
1707 if (i != max)
1708 PerlIO_printf(file, ", ");
1709 }
1710 }
1711 PerlIO_putc(file, ')');
b8fa94d8
MG		 1712 /* The "quality" of a hash is defined as the total number of
1713 comparisons needed to access every element once, relative
1714 to the expected number needed for a random hash.
1715
1716 The total number of comparisons is equal to the sum of
e76cd0fa
AMS		 1717 the squares of the number of entries in each bucket.
1718 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG		 1719 value is
1720 n + n(n-1)/2k
1721 */
1722
3967c732
JD		 1723 for (i = max; i > 0; i--) { /* Precision: count down. */
1724 sum += freq[i] * i * i;
1725 }
155aba94 1726 while ((keys = keys >> 1))
3967c732 1727 pow2 = pow2 << 1;
3967c732 1728 theoret = HvKEYS(sv);
b8fa94d8 1729 theoret += theoret * (theoret-1)/pow2;
3967c732 1730 PerlIO_putc(file, '\n');
6b4667fc 1731 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732
JD		 1732 }
1733 PerlIO_putc(file, '\n');
57def98f
JH		 1734 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv));
1735 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv));
1736 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
bfcb3514
NC		 1737 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1738 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
8d2f4536 1739 {
b9ac451d 1740 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536
NC		 1741 if (mg && mg->mg_obj) {
1742 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1743 }
1744 }
bfcb3514 1745 {
b9ac451d 1746 const char * const hvname = HvNAME_get(sv);
bfcb3514
NC		 1747 if (hvname)
1748 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname);
1749 }
86f55936 1750 if (SvOOK(sv)) {
ad64d0ec 1751 AV * const backrefs
85fbaab2 1752 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
86f55936
NC		 1753 if (backrefs) {
1754 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1755 PTR2UV(backrefs));
ad64d0ec 1756 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC		 1757 dumpops, pvlim);
1758 }
1759 }
bfcb3514 1760 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */
3967c732 1761 HE *he;
85fbaab2 1762 HV * const hv = MUTABLE_HV(sv);
3967c732
JD		 1763 int count = maxnest - nest;
1764
1765 hv_iterinit(hv);
e16e2ff8
NC		 1766 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
1767 && count--) {
98c991d1 1768 STRLEN len;
7a5b473e 1769 const U32 hash = HeHASH(he);
61f9802b
AL		 1770 SV * const keysv = hv_iterkeysv(he);
1771 const char * const keypv = SvPV_const(keysv, len);
1772 SV * const elt = hv_iterval(hv, he);
3967c732 1773
98c991d1
JH		 1774 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1775 if (SvUTF8(keysv))
e9569a7a 1776 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
afce8e55
NC		 1777 if (HeKREHASH(he))
1778 PerlIO_printf(file, "[REHASH] ");
98c991d1 1779 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
3967c732
JD		 1780 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1781 }
1782 hv_iterinit(hv); /* Return to status quo */
1783 }
1784 break;
1785 case SVt_PVCV:
cbf82dd0
NC		 1786 if (SvPOK(sv)) {
1787 STRLEN len;
1788 const char *const proto = SvPV_const(sv, len);
1789 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n",
1790 (int) len, proto);
1791 }
3967c732
JD		 1792 /* FALL THROUGH */
1793 case SVt_PVFM:
1794 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC		 1795 if (!CvISXSUB(sv)) {
1796 if (CvSTART(sv)) {
1797 Perl_dump_indent(aTHX_ level, file,
1798 " START = 0x%"UVxf" ===> %"IVdf"\n",
1799 PTR2UV(CvSTART(sv)),
1800 (IV)sequence_num(CvSTART(sv)));
1801 }
1802 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1803 PTR2UV(CvROOT(sv)));
1804 if (CvROOT(sv) && dumpops) {
1805 do_op_dump(level+1, file, CvROOT(sv));
1806 }
1807 } else {
126f53f3 1808 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 1809
d04ba589 1810 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099
NC		 1811
1812 if (constant) {
1813 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1814 " (CONST SV)\n",
1815 PTR2UV(CvXSUBANY(sv).any_ptr));
1816 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1817 pvlim);
1818 } else {
1819 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1820 (IV)CvXSUBANY(sv).any_i32);
1821 }
1822 }
3967c732 1823 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1824 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
5129b2ca
NC		 1825 if (type == SVt_PVCV)
1826 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 1827 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 1828 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
3967c732 1829 if (type == SVt_PVFM)
57def98f
JH		 1830 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv));
1831 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
dd2155a4
DM		 1832 if (nest < maxnest) {
1833 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
3967c732
JD		 1834 }
1835 {
b9ac451d 1836 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 1837 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 1838 PTR2UV(outside),
cf2093f6
JH		 1839 (!outside ? "null"
1840 : CvANON(outside) ? "ANON"
1841 : (outside == PL_main_cv) ? "MAIN"
1842 : CvUNIQUE(outside) ? "UNIQUE"
1843 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
3967c732
JD		 1844 }
1845 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
ad64d0ec 1846 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 1847 break;
926fc7b6
DM		 1848 case SVt_PVGV:
1849 case SVt_PVLV:
b9ac451d
AL		 1850 if (type == SVt_PVLV) {
1851 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
1852 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
1853 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
1854 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
1855 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
1856 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
1857 dumpops, pvlim);
1858 }
eff3c707
NC		 1859 if (SvVALID(sv)) {
1860 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv));
1861 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv));
1ca32a20
JH		 1862 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv));
1863 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
eff3c707 1864 }
926fc7b6
DM		 1865 if (!isGV_with_GP(sv))
1866 break;
cea2e8a9 1867 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv));
57def98f 1868 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 1869 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
57def98f 1870 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c
GS		 1871 if (!GvGP(sv))
1872 break;
57def98f
JH		 1873 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
1874 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
1875 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
1876 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
1877 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
1878 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
1879 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
1880 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
57def98f 1881 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 1882 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
e39917cc 1883 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
3967c732
JD		 1884 do_gv_dump (level, file, " EGV", GvEGV(sv));
1885 break;
1886 case SVt_PVIO:
57def98f
JH		 1887 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
1888 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
1889 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
1890 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
1891 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
1892 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
1893 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 1894 if (IoTOP_NAME(sv))
cea2e8a9 1895 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC		 1896 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
1897 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
1898 else {
1899 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
1900 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC		 1901 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
1902 maxnest, dumpops, pvlim);
9ba1f565
NC		 1903 }
1904 /* Source filters hide things that are not GVs in these three, so let's
1905 be careful out there. */
27533608 1906 if (IoFMT_NAME(sv))
cea2e8a9 1907 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC		 1908 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
1909 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
1910 else {
1911 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
1912 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC		 1913 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
1914 maxnest, dumpops, pvlim);
9ba1f565 1915 }
27533608 1916 if (IoBOTTOM_NAME(sv))
cea2e8a9 1917 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC		 1918 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
1919 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
1920 else {
1921 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
1922 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC		 1923 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
1924 maxnest, dumpops, pvlim);
9ba1f565 1925 }
27533608 1926 if (isPRINT(IoTYPE(sv)))
cea2e8a9 1927 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 1928 else
cea2e8a9 1929 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 1930 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732
JD		 1931 break;
1932 }
cea89e20 1933 SvREFCNT_dec(d);
3967c732
JD		 1934}
1935
1936void
864dbfa3 1937Perl_sv_dump(pTHX_ SV *sv)
3967c732 1938{
97aff369 1939 dVAR;
7918f24d
NC		 1940
1941 PERL_ARGS_ASSERT_SV_DUMP;
1942
d1029faa
JP		 1943 if (SvROK(sv))
1944 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
1945 else
1946 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 1947}
bd16a5f0
IZ		 1948
1949int
1950Perl_runops_debug(pTHX)
1951{
97aff369 1952 dVAR;
bd16a5f0
IZ		 1953 if (!PL_op) {
1954 if (ckWARN_d(WARN_DEBUGGING))
9014280d 1955 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ		 1956 return 0;
1957 }
1958
9f3673fb 1959 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0
IZ		 1960 do {
1961 PERL_ASYNC_CHECK();
1962 if (PL_debug) {
b9ac451d 1963 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0
IZ		 1964 PerlIO_printf(Perl_debug_log,
1965 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
1966 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
1967 PTR2UV(*PL_watchaddr));
d6721266
DM		 1968 if (DEBUG_s_TEST_) {
1969 if (DEBUG_v_TEST_) {
1970 PerlIO_printf(Perl_debug_log, "\n");
1971 deb_stack_all();
1972 }
1973 else
1974 debstack();
1975 }
1976
1977
bd16a5f0
IZ		 1978 if (DEBUG_t_TEST_) debop(PL_op);
1979 if (DEBUG_P_TEST_) debprof(PL_op);
1980 }
1981 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
9f3673fb 1982 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
bd16a5f0
IZ		 1983
1984 TAINT_NOT;
1985 return 0;
1986}
1987
1988I32
6867be6d 1989Perl_debop(pTHX_ const OP *o)
bd16a5f0 1990{
97aff369 1991 dVAR;
7918f24d
NC		 1992
1993 PERL_ARGS_ASSERT_DEBOP;
1994
1045810a
IZ		 1995 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1996 return 0;
1997
bd16a5f0
IZ		 1998 Perl_deb(aTHX_ "%s", OP_NAME(o));
1999 switch (o->op_type) {
2000 case OP_CONST:
996c9baa 2001 case OP_HINTSEVAL:
6cefa69e 2002 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2003 * may not be active here, so check.
6cefa69e 2004 * Looks like only during compiling the pads are illegal.
7367e658 2005 */
6cefa69e
RU		 2006#ifdef USE_ITHREADS
2007 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2008#endif
7367e658 2009 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ		 2010 break;
2011 case OP_GVSV:
2012 case OP_GV:
2013 if (cGVOPo_gv) {
b9ac451d 2014 SV * const sv = newSV(0);
3b721df9 2015#ifdef PERL_MAD
84021b46 2016 /* FIXME - is this making unwarranted assumptions about the
3b721df9
NC		 2017 UTF-8 cleanliness of the dump file handle? */
2018 SvUTF8_on(sv);
2019#endif
bd61b366 2020 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2021 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
bd16a5f0
IZ		 2022 SvREFCNT_dec(sv);
2023 }
2024 else
2025 PerlIO_printf(Perl_debug_log, "(NULL)");
2026 break;
2027 case OP_PADSV:
2028 case OP_PADAV:
2029 case OP_PADHV:
a3b680e6 2030 {
bd16a5f0 2031 /* print the lexical's name */
b9ac451d 2032 CV * const cv = deb_curcv(cxstack_ix);
a3b680e6 2033 SV *sv;
bd16a5f0 2034 if (cv) {
b9ac451d 2035 AV * const padlist = CvPADLIST(cv);
502c6561 2036 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE));
bd16a5f0
IZ		 2037 sv = *av_fetch(comppad, o->op_targ, FALSE);
2038 } else
a0714e2c 2039 sv = NULL;
bd16a5f0 2040 if (sv)
b9ac451d 2041 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
bd16a5f0 2042 else
b9ac451d 2043 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
a3b680e6 2044 }
bd16a5f0
IZ		 2045 break;
2046 default:
091ab601 2047 break;
bd16a5f0
IZ		 2048 }
2049 PerlIO_printf(Perl_debug_log, "\n");
2050 return 0;
2051}
2052
2053STATIC CV*
61f9802b 2054S_deb_curcv(pTHX_ const I32 ix)
bd16a5f0 2055{
97aff369 2056 dVAR;
b9ac451d 2057 const PERL_CONTEXT * const cx = &cxstack[ix];
bd16a5f0
IZ		 2058 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2059 return cx->blk_sub.cv;
2060 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2061 return PL_compcv;
2062 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2063 return PL_main_cv;
2064 else if (ix <= 0)
601f1833 2065 return NULL;
bd16a5f0
IZ		 2066 else
2067 return deb_curcv(ix - 1);
2068}
2069
2070void
2071Perl_watch(pTHX_ char **addr)
2072{
97aff369 2073 dVAR;
7918f24d
NC		 2074
2075 PERL_ARGS_ASSERT_WATCH;
2076
bd16a5f0
IZ		 2077 PL_watchaddr = addr;
2078 PL_watchok = *addr;
2079 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2080 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2081}
2082
2083STATIC void
e1ec3a88 2084S_debprof(pTHX_ const OP *o)
bd16a5f0 2085{
97aff369 2086 dVAR;
7918f24d
NC		 2087
2088 PERL_ARGS_ASSERT_DEBPROF;
2089
61f9802b 2090 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2091 return;
bd16a5f0 2092 if (!PL_profiledata)
a02a5408 2093 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ		 2094 ++PL_profiledata[o->op_type];
2095}
2096
2097void
2098Perl_debprofdump(pTHX)
2099{
97aff369 2100 dVAR;
bd16a5f0
IZ		 2101 unsigned i;
2102 if (!PL_profiledata)
2103 return;
2104 for (i = 0; i < MAXO; i++) {
2105 if (PL_profiledata[i])
2106 PerlIO_printf(Perl_debug_log,
2107 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2108 PL_op_name[i]);
2109 }
2110}
66610fdd 2111
3b721df9
NC		 2112#ifdef PERL_MAD
2113/*
2114 * XML variants of most of the above routines
2115 */
2116
4136a0f7 2117STATIC void
3b721df9
NC		 2118S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2119{
2120 va_list args;
7918f24d
NC		 2121
2122 PERL_ARGS_ASSERT_XMLDUMP_ATTR;
2123
3b721df9
NC		 2124 PerlIO_printf(file, "\n ");
2125 va_start(args, pat);
2126 xmldump_vindent(level, file, pat, &args);
2127 va_end(args);
2128}
2129
2130
2131void
2132Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
2133{
2134 va_list args;
7918f24d 2135 PERL_ARGS_ASSERT_XMLDUMP_INDENT;
3b721df9
NC		 2136 va_start(args, pat);
2137 xmldump_vindent(level, file, pat, &args);
2138 va_end(args);
2139}
2140
2141void
2142Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
2143{
7918f24d
NC		 2144 PERL_ARGS_ASSERT_XMLDUMP_VINDENT;
2145
3b721df9
NC		 2146 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
2147 PerlIO_vprintf(file, pat, *args);
2148}
2149
2150void
2151Perl_xmldump_all(pTHX)
2152{
2153 PerlIO_setlinebuf(PL_xmlfp);
2154 if (PL_main_root)
2155 op_xmldump(PL_main_root);
2156 if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
2157 PerlIO_close(PL_xmlfp);
2158 PL_xmlfp = 0;
2159}
2160
2161void
2162Perl_xmldump_packsubs(pTHX_ const HV *stash)
2163{
2164 I32 i;
2165 HE *entry;
2166
7918f24d
NC		 2167 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS;
2168
3b721df9
NC		 2169 if (!HvARRAY(stash))
2170 return;
2171 for (i = 0; i <= (I32) HvMAX(stash); i++) {
2172 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
159b6efe 2173 GV *gv = MUTABLE_GV(HeVAL(entry));
3b721df9
NC		 2174 HV *hv;
2175 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
2176 continue;
2177 if (GvCVu(gv))
2178 xmldump_sub(gv);
2179 if (GvFORM(gv))
2180 xmldump_form(gv);
2181 if (HeKEY(entry)[HeKLEN(entry)-1] == ':'
2182 && (hv = GvHV(gv)) && hv != PL_defstash)
2183 xmldump_packsubs(hv); /* nested package */
2184 }
2185 }
2186}
2187
2188void
2189Perl_xmldump_sub(pTHX_ const GV *gv)
2190{
61f9802b 2191 SV * const sv = sv_newmortal();
3b721df9 2192
7918f24d
NC		 2193 PERL_ARGS_ASSERT_XMLDUMP_SUB;
2194
1a9a51d4 2195 gv_fullname3(sv, gv, NULL);
3b721df9
NC		 2196 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
2197 if (CvXSUB(GvCV(gv)))
2198 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n",
2199 PTR2UV(CvXSUB(GvCV(gv))),
2200 (int)CvXSUBANY(GvCV(gv)).any_i32);
2201 else if (CvROOT(GvCV(gv)))
2202 op_xmldump(CvROOT(GvCV(gv)));
2203 else
2204 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2205}
2206
2207void
2208Perl_xmldump_form(pTHX_ const GV *gv)
2209{
61f9802b 2210 SV * const sv = sv_newmortal();
3b721df9 2211
7918f24d
NC		 2212 PERL_ARGS_ASSERT_XMLDUMP_FORM;
2213
1a9a51d4 2214 gv_fullname3(sv, gv, NULL);
3b721df9
NC		 2215 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv));
2216 if (CvROOT(GvFORM(gv)))
2217 op_xmldump(CvROOT(GvFORM(gv)));
2218 else
2219 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n");
2220}
2221
2222void
2223Perl_xmldump_eval(pTHX)
2224{
2225 op_xmldump(PL_eval_root);
2226}
2227
2228char *
2229Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv)
2230{
7918f24d 2231 PERL_ARGS_ASSERT_SV_CATXMLSV;
3b721df9
NC		 2232 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv));
2233}
2234
2235char *
20f84293 2236Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8)
3b721df9
NC		 2237{
2238 unsigned int c;
61f9802b 2239 const char * const e = pv + len;
20f84293 2240 const char * const start = pv;
3b721df9
NC		 2241 STRLEN dsvcur;
2242 STRLEN cl;
2243
7918f24d
NC		 2244 PERL_ARGS_ASSERT_SV_CATXMLPVN;
2245
76f68e9b 2246 sv_catpvs(dsv,"");
3b721df9
NC		 2247 dsvcur = SvCUR(dsv); /* in case we have to restart */
2248
2249 retry:
2250 while (pv < e) {
2251 if (utf8) {
2252 c = utf8_to_uvchr((U8*)pv, &cl);
2253 if (cl == 0) {
2254 SvCUR(dsv) = dsvcur;
2255 pv = start;
2256 utf8 = 0;
2257 goto retry;
2258 }
2259 }
2260 else
2261 c = (*pv & 255);
2262
2263 switch (c) {
2264 case 0x00:
2265 case 0x01:
2266 case 0x02:
2267 case 0x03:
2268 case 0x04:
2269 case 0x05:
2270 case 0x06:
2271 case 0x07:
2272 case 0x08:
2273 case 0x0b:
2274 case 0x0c:
2275 case 0x0e:
2276 case 0x0f:
2277 case 0x10:
2278 case 0x11:
2279 case 0x12:
2280 case 0x13:
2281 case 0x14:
2282 case 0x15:
2283 case 0x16:
2284 case 0x17:
2285 case 0x18:
2286 case 0x19:
2287 case 0x1a:
2288 case 0x1b:
2289 case 0x1c:
2290 case 0x1d:
2291 case 0x1e:
2292 case 0x1f:
2293 case 0x7f:
2294 case 0x80:
2295 case 0x81:
2296 case 0x82:
2297 case 0x83:
2298 case 0x84:
2299 case 0x86:
2300 case 0x87:
2301 case 0x88:
2302 case 0x89:
2303 case 0x90:
2304 case 0x91:
2305 case 0x92:
2306 case 0x93:
2307 case 0x94:
2308 case 0x95:
2309 case 0x96:
2310 case 0x97:
2311 case 0x98:
2312 case 0x99:
2313 case 0x9a:
2314 case 0x9b:
2315 case 0x9c:
2316 case 0x9d:
2317 case 0x9e:
2318 case 0x9f:
2319 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2320 break;
2321 case '<':
f3a2811a 2322 sv_catpvs(dsv, "&lt;");
3b721df9
NC		 2323 break;
2324 case '>':
f3a2811a 2325 sv_catpvs(dsv, "&gt;");
3b721df9
NC		 2326 break;
2327 case '&':
f3a2811a 2328 sv_catpvs(dsv, "&amp;");
3b721df9
NC		 2329 break;
2330 case '"':
49de0815 2331 sv_catpvs(dsv, "&#34;");
3b721df9
NC		 2332 break;
2333 default:
2334 if (c < 0xD800) {
2335 if (c < 32 || c > 127) {
2336 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2337 }
2338 else {
5e7aa789
NC		 2339 const char string = (char) c;
2340 sv_catpvn(dsv, &string, 1);
3b721df9
NC		 2341 }
2342 break;
2343 }
2344 if ((c >= 0xD800 && c <= 0xDB7F) ||
2345 (c >= 0xDC00 && c <= 0xDFFF) ||
2346 (c >= 0xFFF0 && c <= 0xFFFF) ||
2347 c > 0x10ffff)
2348 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c);
2349 else
2350 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c);
2351 }
2352
2353 if (utf8)
2354 pv += UTF8SKIP(pv);
2355 else
2356 pv++;
2357 }
2358
2359 return SvPVX(dsv);
2360}
2361
2362char *
2363Perl_sv_xmlpeek(pTHX_ SV *sv)
2364{
61f9802b 2365 SV * const t = sv_newmortal();
3b721df9
NC		 2366 STRLEN n_a;
2367 int unref = 0;
2368
7918f24d
NC		 2369 PERL_ARGS_ASSERT_SV_XMLPEEK;
2370
3b721df9 2371 sv_utf8_upgrade(t);
76f68e9b 2372 sv_setpvs(t, "");
3b721df9
NC		 2373 /* retry: */
2374 if (!sv) {
2375 sv_catpv(t, "VOID=\"\"");
2376 goto finish;
2377 }
ad64d0ec 2378 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') {
3b721df9
NC		 2379 sv_catpv(t, "WILD=\"\"");
2380 goto finish;
2381 }
2382 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
2383 if (sv == &PL_sv_undef) {
2384 sv_catpv(t, "SV_UNDEF=\"1\"");
2385 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2386 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2387 SvREADONLY(sv))
2388 goto finish;
2389 }
2390 else if (sv == &PL_sv_no) {
2391 sv_catpv(t, "SV_NO=\"1\"");
2392 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2393 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2394 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2395 SVp_POK|SVp_NOK)) &&
2396 SvCUR(sv) == 0 &&
2397 SvNVX(sv) == 0.0)
2398 goto finish;
2399 }
2400 else if (sv == &PL_sv_yes) {
2401 sv_catpv(t, "SV_YES=\"1\"");
2402 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
2403 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2404 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
2405 SVp_POK|SVp_NOK)) &&
2406 SvCUR(sv) == 1 &&
2407 SvPVX(sv) && *SvPVX(sv) == '1' &&
2408 SvNVX(sv) == 1.0)
2409 goto finish;
2410 }
2411 else {
2412 sv_catpv(t, "SV_PLACEHOLDER=\"1\"");
2413 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
2414 SVs_GMG|SVs_SMG|SVs_RMG)) &&
2415 SvREADONLY(sv))
2416 goto finish;
2417 }
2418 sv_catpv(t, " XXX=\"\" ");
2419 }
2420 else if (SvREFCNT(sv) == 0) {
2421 sv_catpv(t, " refcnt=\"0\"");
2422 unref++;
2423 }
2424 else if (DEBUG_R_TEST_) {
2425 int is_tmp = 0;
2426 I32 ix;
2427 /* is this SV on the tmps stack? */
2428 for (ix=PL_tmps_ix; ix>=0; ix--) {
2429 if (PL_tmps_stack[ix] == sv) {
2430 is_tmp = 1;
2431 break;
2432 }
2433 }
2434 if (SvREFCNT(sv) > 1)
2435 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv),
2436 is_tmp ? "T" : "");
2437 else if (is_tmp)
2438 sv_catpv(t, " DRT=\"<T>\"");
2439 }
2440
2441 if (SvROK(sv)) {
2442 sv_catpv(t, " ROK=\"\"");
2443 }
2444 switch (SvTYPE(sv)) {
2445 default:
2446 sv_catpv(t, " FREED=\"1\"");
2447 goto finish;
2448
2449 case SVt_NULL:
2450 sv_catpv(t, " UNDEF=\"1\"");
2451 goto finish;
2452 case SVt_IV:
2453 sv_catpv(t, " IV=\"");
2454 break;
2455 case SVt_NV:
2456 sv_catpv(t, " NV=\"");
2457 break;
3b721df9
NC		 2458 case SVt_PV:
2459 sv_catpv(t, " PV=\"");
2460 break;
2461 case SVt_PVIV:
2462 sv_catpv(t, " PVIV=\"");
2463 break;
2464 case SVt_PVNV:
2465 sv_catpv(t, " PVNV=\"");
2466 break;
2467 case SVt_PVMG:
2468 sv_catpv(t, " PVMG=\"");
2469 break;
2470 case SVt_PVLV:
2471 sv_catpv(t, " PVLV=\"");
2472 break;
2473 case SVt_PVAV:
2474 sv_catpv(t, " AV=\"");
2475 break;
2476 case SVt_PVHV:
2477 sv_catpv(t, " HV=\"");
2478 break;
2479 case SVt_PVCV:
2480 if (CvGV(sv))
2481 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv)));
2482 else
2483 sv_catpv(t, " CV=\"()\"");
2484 goto finish;
2485 case SVt_PVGV:
2486 sv_catpv(t, " GV=\"");
2487 break;
cecf5685
NC		 2488 case SVt_BIND:
2489 sv_catpv(t, " BIND=\"");
3b721df9 2490 break;
d914baab 2491 case SVt_REGEXP:
4df7f6af
NC		 2492 sv_catpv(t, " ORANGE=\"");
2493 break;
3b721df9
NC		 2494 case SVt_PVFM:
2495 sv_catpv(t, " FM=\"");
2496 break;
2497 case SVt_PVIO:
2498 sv_catpv(t, " IO=\"");
2499 break;
2500 }
2501
2502 if (SvPOKp(sv)) {
2503 if (SvPVX(sv)) {
2504 sv_catxmlsv(t, sv);
2505 }
2506 }
2507 else if (SvNOKp(sv)) {
2508 STORE_NUMERIC_LOCAL_SET_STANDARD();
2509 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv));
2510 RESTORE_NUMERIC_LOCAL();
2511 }
2512 else if (SvIOKp(sv)) {
2513 if (SvIsUV(sv))
2514 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv));
2515 else
2516 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv));
2517 }
2518 else
2519 sv_catpv(t, "");
2520 sv_catpv(t, "\"");
2521
2522 finish:
61f9802b
AL		 2523 while (unref--)
2524 sv_catpv(t, ")");
3b721df9
NC		 2525 return SvPV(t, n_a);
2526}
2527
2528void
2529Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
2530{
7918f24d
NC		 2531 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP;
2532
3b721df9
NC		 2533 if (!pm) {
2534 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n");
2535 return;
2536 }
2537 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n");
2538 level++;
2539 if (PM_GETRE(pm)) {
d914baab 2540 REGEXP *const r = PM_GETRE(pm);
643e696a 2541 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
ad64d0ec 2542 sv_catxmlsv(tmpsv, MUTABLE_SV(r));
3b721df9
NC		 2543 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n",
2544 SvPVX(tmpsv));
2545 SvREFCNT_dec(tmpsv);
2546 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n",
2547 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP");
2548 }
2549 else
2550 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n");
d914baab 2551 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
3df43ef7 2552 SV * const tmpsv = pm_description(pm);
3b721df9
NC		 2553 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2554 SvREFCNT_dec(tmpsv);
2555 }
2556
2557 level--;
20e98b0f 2558 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
3b721df9
NC		 2559 Perl_xmldump_indent(aTHX_ level, file, ">\n");
2560 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n");
20e98b0f 2561 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot);
3b721df9
NC		 2562 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n");
2563 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n");
2564 }
2565 else
2566 Perl_xmldump_indent(aTHX_ level, file, "/>\n");
2567}
2568
2569void
2570Perl_pmop_xmldump(pTHX_ const PMOP *pm)
2571{
2572 do_pmop_xmldump(0, PL_xmlfp, pm);
2573}
2574
2575void
2576Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o)
2577{
2578 UV seq;
2579 int contents = 0;
7918f24d
NC		 2580
2581 PERL_ARGS_ASSERT_DO_OP_XMLDUMP;
2582
3b721df9
NC		 2583 if (!o)
2584 return;
2585 sequence(o);
2586 seq = sequence_num(o);
2587 Perl_xmldump_indent(aTHX_ level, file,
2588 "<op_%s seq=\"%"UVuf" -> ",
2589 OP_NAME(o),
2590 seq);
2591 level++;
2592 if (o->op_next)
2593 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"",
2594 sequence_num(o->op_next));
2595 else
2596 PerlIO_printf(file, "DONE\"");
2597
2598 if (o->op_targ) {
2599 if (o->op_type == OP_NULL)
2600 {
2601 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]);
2602 if (o->op_targ == OP_NEXTSTATE)
2603 {
2604 if (CopLINE(cCOPo))
f5992bc4 2605 PerlIO_printf(file, " line=\"%"UVuf"\"",
3b721df9
NC		 2606 (UV)CopLINE(cCOPo));
2607 if (CopSTASHPV(cCOPo))
2608 PerlIO_printf(file, " package=\"%s\"",
2609 CopSTASHPV(cCOPo));
4b65a919 2610 if (CopLABEL(cCOPo))
3b721df9 2611 PerlIO_printf(file, " label=\"%s\"",
4b65a919 2612 CopLABEL(cCOPo));
3b721df9
NC		 2613 }
2614 }
2615 else
2616 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ);
2617 }
2618#ifdef DUMPADDR
2619 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next);
2620#endif
2621 if (o->op_flags) {
76f68e9b 2622 SV * const tmpsv = newSVpvs("");
3b721df9
NC		 2623 switch (o->op_flags & OPf_WANT) {
2624 case OPf_WANT_VOID:
2625 sv_catpv(tmpsv, ",VOID");
2626 break;
2627 case OPf_WANT_SCALAR:
2628 sv_catpv(tmpsv, ",SCALAR");
2629 break;
2630 case OPf_WANT_LIST:
2631 sv_catpv(tmpsv, ",LIST");
2632 break;
2633 default:
2634 sv_catpv(tmpsv, ",UNKNOWN");
2635 break;
2636 }
2637 if (o->op_flags & OPf_KIDS)
2638 sv_catpv(tmpsv, ",KIDS");
2639 if (o->op_flags & OPf_PARENS)
2640 sv_catpv(tmpsv, ",PARENS");
2641 if (o->op_flags & OPf_STACKED)
2642 sv_catpv(tmpsv, ",STACKED");
2643 if (o->op_flags & OPf_REF)
2644 sv_catpv(tmpsv, ",REF");
2645 if (o->op_flags & OPf_MOD)
2646 sv_catpv(tmpsv, ",MOD");
2647 if (o->op_flags & OPf_SPECIAL)
2648 sv_catpv(tmpsv, ",SPECIAL");
2649 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
2650 SvREFCNT_dec(tmpsv);
2651 }
2652 if (o->op_private) {
76f68e9b 2653 SV * const tmpsv = newSVpvs("");
3b721df9
NC		 2654 if (PL_opargs[o->op_type] & OA_TARGLEX) {
2655 if (o->op_private & OPpTARGET_MY)
2656 sv_catpv(tmpsv, ",TARGET_MY");
2657 }
2658 else if (o->op_type == OP_LEAVESUB ||
2659 o->op_type == OP_LEAVE ||
2660 o->op_type == OP_LEAVESUBLV ||
2661 o->op_type == OP_LEAVEWRITE) {
2662 if (o->op_private & OPpREFCOUNTED)
2663 sv_catpv(tmpsv, ",REFCOUNTED");
2664 }
2665 else if (o->op_type == OP_AASSIGN) {
2666 if (o->op_private & OPpASSIGN_COMMON)
2667 sv_catpv(tmpsv, ",COMMON");
2668 }
2669 else if (o->op_type == OP_SASSIGN) {
2670 if (o->op_private & OPpASSIGN_BACKWARDS)
2671 sv_catpv(tmpsv, ",BACKWARDS");
2672 }
2673 else if (o->op_type == OP_TRANS) {
2674 if (o->op_private & OPpTRANS_SQUASH)
2675 sv_catpv(tmpsv, ",SQUASH");
2676 if (o->op_private & OPpTRANS_DELETE)
2677 sv_catpv(tmpsv, ",DELETE");
2678 if (o->op_private & OPpTRANS_COMPLEMENT)
2679 sv_catpv(tmpsv, ",COMPLEMENT");
2680 if (o->op_private & OPpTRANS_IDENTICAL)
2681 sv_catpv(tmpsv, ",IDENTICAL");
2682 if (o->op_private & OPpTRANS_GROWS)
2683 sv_catpv(tmpsv, ",GROWS");
2684 }
2685 else if (o->op_type == OP_REPEAT) {
2686 if (o->op_private & OPpREPEAT_DOLIST)
2687 sv_catpv(tmpsv, ",DOLIST");
2688 }
2689 else if (o->op_type == OP_ENTERSUB ||
2690 o->op_type == OP_RV2SV ||
2691 o->op_type == OP_GVSV ||
2692 o->op_type == OP_RV2AV ||
2693 o->op_type == OP_RV2HV ||
2694 o->op_type == OP_RV2GV ||
2695 o->op_type == OP_AELEM ||
2696 o->op_type == OP_HELEM )
2697 {
2698 if (o->op_type == OP_ENTERSUB) {
2699 if (o->op_private & OPpENTERSUB_AMPER)
2700 sv_catpv(tmpsv, ",AMPER");
2701 if (o->op_private & OPpENTERSUB_DB)
2702 sv_catpv(tmpsv, ",DB");
2703 if (o->op_private & OPpENTERSUB_HASTARG)
2704 sv_catpv(tmpsv, ",HASTARG");
2705 if (o->op_private & OPpENTERSUB_NOPAREN)
2706 sv_catpv(tmpsv, ",NOPAREN");
2707 if (o->op_private & OPpENTERSUB_INARGS)
2708 sv_catpv(tmpsv, ",INARGS");
2709 if (o->op_private & OPpENTERSUB_NOMOD)
2710 sv_catpv(tmpsv, ",NOMOD");
2711 }
2712 else {
2713 switch (o->op_private & OPpDEREF) {
2714 case OPpDEREF_SV:
2715 sv_catpv(tmpsv, ",SV");
2716 break;
2717 case OPpDEREF_AV:
2718 sv_catpv(tmpsv, ",AV");
2719 break;
2720 case OPpDEREF_HV:
2721 sv_catpv(tmpsv, ",HV");
2722 break;
2723 }
2724 if (o->op_private & OPpMAYBE_LVSUB)
2725 sv_catpv(tmpsv, ",MAYBE_LVSUB");
2726 }
2727 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
2728 if (o->op_private & OPpLVAL_DEFER)
2729 sv_catpv(tmpsv, ",LVAL_DEFER");
2730 }
2731 else {
2732 if (o->op_private & HINT_STRICT_REFS)
2733 sv_catpv(tmpsv, ",STRICT_REFS");
2734 if (o->op_private & OPpOUR_INTRO)
2735 sv_catpv(tmpsv, ",OUR_INTRO");
2736 }
2737 }
2738 else if (o->op_type == OP_CONST) {
2739 if (o->op_private & OPpCONST_BARE)
2740 sv_catpv(tmpsv, ",BARE");
2741 if (o->op_private & OPpCONST_STRICT)
2742 sv_catpv(tmpsv, ",STRICT");
2743 if (o->op_private & OPpCONST_ARYBASE)
2744 sv_catpv(tmpsv, ",ARYBASE");
2745 if (o->op_private & OPpCONST_WARNING)
2746 sv_catpv(tmpsv, ",WARNING");
2747 if (o->op_private & OPpCONST_ENTERED)
2748 sv_catpv(tmpsv, ",ENTERED");
2749 }
2750 else if (o->op_type == OP_FLIP) {
2751 if (o->op_private & OPpFLIP_LINENUM)
2752 sv_catpv(tmpsv, ",LINENUM");
2753 }
2754 else if (o->op_type == OP_FLOP) {
2755 if (o->op_private & OPpFLIP_LINENUM)
2756 sv_catpv(tmpsv, ",LINENUM");
2757 }
2758 else if (o->op_type == OP_RV2CV) {
2759 if (o->op_private & OPpLVAL_INTRO)
2760 sv_catpv(tmpsv, ",INTRO");
2761 }
2762 else if (o->op_type == OP_GV) {
2763 if (o->op_private & OPpEARLY_CV)
2764 sv_catpv(tmpsv, ",EARLY_CV");
2765 }
2766 else if (o->op_type == OP_LIST) {
2767 if (o->op_private & OPpLIST_GUESSED)
2768 sv_catpv(tmpsv, ",GUESSED");
2769 }
2770 else if (o->op_type == OP_DELETE) {
2771 if (o->op_private & OPpSLICE)
2772 sv_catpv(tmpsv, ",SLICE");
2773 }
2774 else if (o->op_type == OP_EXISTS) {
2775 if (o->op_private & OPpEXISTS_SUB)
2776 sv_catpv(tmpsv, ",EXISTS_SUB");
2777 }
2778 else if (o->op_type == OP_SORT) {
2779 if (o->op_private & OPpSORT_NUMERIC)
2780 sv_catpv(tmpsv, ",NUMERIC");
2781 if (o->op_private & OPpSORT_INTEGER)
2782 sv_catpv(tmpsv, ",INTEGER");
2783 if (o->op_private & OPpSORT_REVERSE)
2784 sv_catpv(tmpsv, ",REVERSE");
2785 }
3b721df9
NC		 2786 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) {
2787 if (o->op_private & OPpOPEN_IN_RAW)
2788 sv_catpv(tmpsv, ",IN_RAW");
2789 if (o->op_private & OPpOPEN_IN_CRLF)
2790 sv_catpv(tmpsv, ",IN_CRLF");
2791 if (o->op_private & OPpOPEN_OUT_RAW)
2792 sv_catpv(tmpsv, ",OUT_RAW");
2793 if (o->op_private & OPpOPEN_OUT_CRLF)
2794 sv_catpv(tmpsv, ",OUT_CRLF");
2795 }
2796 else if (o->op_type == OP_EXIT) {
2797 if (o->op_private & OPpEXIT_VMSISH)
2798 sv_catpv(tmpsv, ",EXIT_VMSISH");
2799 if (o->op_private & OPpHUSH_VMSISH)
2800 sv_catpv(tmpsv, ",HUSH_VMSISH");
2801 }
2802 else if (o->op_type == OP_DIE) {
2803 if (o->op_private & OPpHUSH_VMSISH)
2804 sv_catpv(tmpsv, ",HUSH_VMSISH");
2805 }
2806 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
6ecf81d6 2807 if (OP_IS_FILETEST_ACCESS(o->op_type) && o->op_private & OPpFT_ACCESS)
3b721df9
NC		 2808 sv_catpv(tmpsv, ",FT_ACCESS");
2809 if (o->op_private & OPpFT_STACKED)
2810 sv_catpv(tmpsv, ",FT_STACKED");
2811 }
2812 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
2813 sv_catpv(tmpsv, ",INTRO");
2814 if (SvCUR(tmpsv))
2815 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1);
2816 SvREFCNT_dec(tmpsv);
2817 }
2818
2819 switch (o->op_type) {
2820 case OP_AELEMFAST:
2821 if (o->op_flags & OPf_SPECIAL) {
2822 break;
2823 }
2824 case OP_GVSV:
2825 case OP_GV:
2826#ifdef USE_ITHREADS
2827 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix);
2828#else
2829 if (cSVOPo->op_sv) {
d914baab
NC		 2830 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE);
2831 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE);
3b721df9
NC		 2832 char *s;
2833 STRLEN len;
2834 ENTER;
2835 SAVEFREESV(tmpsv1);
2836 SAVEFREESV(tmpsv2);
159b6efe 2837 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL);
3b721df9
NC		 2838 s = SvPV(tmpsv1,len);
2839 sv_catxmlpvn(tmpsv2, s, len, 1);
2840 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len));
2841 LEAVE;
2842 }
2843 else
2844 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\"");
2845#endif
2846 break;
2847 case OP_CONST:
996c9baa 2848 case OP_HINTSEVAL:
3b721df9
NC		 2849 case OP_METHOD_NAMED:
2850#ifndef USE_ITHREADS
2851 /* with ITHREADS, consts are stored in the pad, and the right pad
2852 * may not be active here, so skip */
2853 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv));
2854#endif
2855 break;
2856 case OP_ANONCODE:
2857 if (!contents) {
2858 contents = 1;
2859 PerlIO_printf(file, ">\n");
2860 }
2861 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv));
2862 break;
3b721df9
NC		 2863 case OP_NEXTSTATE:
2864 case OP_DBSTATE:
2865 if (CopLINE(cCOPo))
f5992bc4 2866 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"",
3b721df9
NC		 2867 (UV)CopLINE(cCOPo));
2868 if (CopSTASHPV(cCOPo))
2869 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"",
2870 CopSTASHPV(cCOPo));
4b65a919 2871 if (CopLABEL(cCOPo))
3b721df9 2872 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"",
4b65a919 2873 CopLABEL(cCOPo));
3b721df9
NC		 2874 break;
2875 case OP_ENTERLOOP:
2876 S_xmldump_attr(aTHX_ level, file, "redo=\"");
2877 if (cLOOPo->op_redoop)
2878 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop));
2879 else
2880 PerlIO_printf(file, "DONE\"");
2881 S_xmldump_attr(aTHX_ level, file, "next=\"");
2882 if (cLOOPo->op_nextop)
2883 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop));
2884 else
2885 PerlIO_printf(file, "DONE\"");
2886 S_xmldump_attr(aTHX_ level, file, "last=\"");
2887 if (cLOOPo->op_lastop)
2888 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop));
2889 else
2890 PerlIO_printf(file, "DONE\"");
2891 break;
2892 case OP_COND_EXPR:
2893 case OP_RANGE:
2894 case OP_MAPWHILE:
2895 case OP_GREPWHILE:
2896 case OP_OR:
2897 case OP_AND:
2898 S_xmldump_attr(aTHX_ level, file, "other=\"");
2899 if (cLOGOPo->op_other)
2900 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other));
2901 else
2902 PerlIO_printf(file, "DONE\"");
2903 break;
2904 case OP_LEAVE:
2905 case OP_LEAVEEVAL:
2906 case OP_LEAVESUB:
2907 case OP_LEAVESUBLV:
2908 case OP_LEAVEWRITE:
2909 case OP_SCOPE:
2910 if (o->op_private & OPpREFCOUNTED)
2911 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ);
2912 break;
2913 default:
2914 break;
2915 }
2916
2917 if (PL_madskills && o->op_madprop) {
fb2b694a 2918 char prevkey = '\0';
d914baab 2919 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE);
20f84293 2920 const MADPROP* mp = o->op_madprop;
61f9802b 2921
3b721df9
NC		 2922 if (!contents) {
2923 contents = 1;
2924 PerlIO_printf(file, ">\n");
2925 }
2926 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n");
2927 level++;
2928 while (mp) {
2929 char tmp = mp->mad_key;
76f68e9b 2930 sv_setpvs(tmpsv,"\"");
3b721df9
NC		 2931 if (tmp)
2932 sv_catxmlpvn(tmpsv, &tmp, 1, 0);
fb2b694a
GG		 2933 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */
2934 sv_catxmlpvn(tmpsv, &prevkey, 1, 0);
2935 else
2936 prevkey = tmp;
3b721df9
NC		 2937 sv_catpv(tmpsv, "\"");
2938 switch (mp->mad_type) {
2939 case MAD_NULL:
2940 sv_catpv(tmpsv, "NULL");
2941 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv));
2942 break;
2943 case MAD_PV:
2944 sv_catpv(tmpsv, " val=\"");
2945 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1);
2946 sv_catpv(tmpsv, "\"");
2947 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv));
2948 break;
2949 case MAD_SV:
2950 sv_catpv(tmpsv, " val=\"");
ad64d0ec 2951 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val));
3b721df9
NC		 2952 sv_catpv(tmpsv, "\"");
2953 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv));
2954 break;
2955 case MAD_OP:
2956 if ((OP*)mp->mad_val) {
2957 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv));
2958 do_op_xmldump(level+1, file, (OP*)mp->mad_val);
2959 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n");
2960 }
2961 break;
2962 default:
2963 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv));
2964 break;
2965 }
2966 mp = mp->mad_next;
2967 }
2968 level--;
2969 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n");
2970
2971 SvREFCNT_dec(tmpsv);
2972 }
2973
2974 switch (o->op_type) {
2975 case OP_PUSHRE:
2976 case OP_MATCH:
2977 case OP_QR:
2978 case OP_SUBST:
2979 if (!contents) {
2980 contents = 1;
2981 PerlIO_printf(file, ">\n");
2982 }
2983 do_pmop_xmldump(level, file, cPMOPo);
2984 break;
2985 default:
2986 break;
2987 }
2988
2989 if (o->op_flags & OPf_KIDS) {
2990 OP *kid;
2991 if (!contents) {
2992 contents = 1;
2993 PerlIO_printf(file, ">\n");
2994 }
2995 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2996 do_op_xmldump(level, file, kid);
2997 }
2998
2999 if (contents)
3000 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o));
3001 else
3002 PerlIO_printf(file, " />\n");
3003}
3004
3005void
3006Perl_op_xmldump(pTHX_ const OP *o)
3007{
7918f24d
NC		 3008 PERL_ARGS_ASSERT_OP_XMLDUMP;
3009
3b721df9
NC		 3010 do_op_xmldump(0, PL_xmlfp, o);
3011}
3012#endif
3013
66610fdd
RGS		 3014/*
3015 * Local variables:
3016 * c-indentation-style: bsd
3017 * c-basic-offset: 4
3018 * indent-tabs-mode: t
3019 * End:
3020 *
37442d52
RGS		 3021 * ex: set ts=8 sts=4 sw=4 noet:
3022 */
Unnamed repository; edit this file 'description' to name the repository.