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