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