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