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