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