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