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