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