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