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