This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Eliminate SVrepl_EVAL and SvEVALED()
[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.
dcccc8ff
KW
23
24=head1 Display and Dump functions
166f8a29
DM
25 */
26
8d063cd8 27#include "EXTERN.h"
864dbfa3 28#define PERL_IN_DUMP_C
8d063cd8 29#include "perl.h"
f722798b 30#include "regcomp.h"
0bd48802 31
5357ca29
NC
32static const char* const svtypenames[SVt_LAST] = {
33 "NULL",
34 "IV",
b53eecb4 35 "NV",
5357ca29 36 "PV",
e94d9b54 37 "INVLIST",
5357ca29
NC
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",
54 "IV",
b53eecb4 55 "NV",
5357ca29 56 "PV",
e94d9b54 57 "INVLST",
5357ca29
NC
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 88
0eb335df
BF
89#define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
90 (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
91 PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
92 | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
93
3df15adc 94/*
87cea99e 95=for apidoc pv_escape
3df15adc 96
796b6530
KW
97Escapes at most the first C<count> chars of C<pv> and puts the results into
98C<dsv> such that the size of the escaped string will not exceed C<max> chars
9a63e366 99and will not contain any incomplete escape sequences. The number of bytes
796b6530
KW
100escaped will be returned in the C<STRLEN *escaped> parameter if it is not null.
101When the C<dsv> parameter is null no escaping actually occurs, but the number
4420a417 102of bytes that would be escaped were it not null will be calculated.
3df15adc 103
796b6530 104If flags contains C<PERL_PV_ESCAPE_QUOTE> then any double quotes in the string
ab3bbdeb 105will also be escaped.
3df15adc
YO
106
107Normally the SV will be cleared before the escaped string is prepared,
796b6530 108but when C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur.
ab3bbdeb 109
796b6530
KW
110If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8
111if C<PERL_PV_ESCAPE_UNI_DETECT> is set then the input string is scanned
e5860534 112using C<is_utf8_string()> to determine if it is UTF-8.
ab3bbdeb 113
796b6530
KW
114If C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output
115using C<\x01F1> style escapes, otherwise if C<PERL_PV_ESCAPE_NONASCII> is set, only
951cbe24 116non-ASCII chars will be escaped using this style; otherwise, only chars above
681f01c2 117255 will be so escaped; other non printable chars will use octal or
72d33970 118common escaped patterns like C<\n>.
796b6530 119Otherwise, if C<PERL_PV_ESCAPE_NOBACKSLASH>
681f01c2 120then all chars below 255 will be treated as printable and
ab3bbdeb
YO
121will be output as literals.
122
796b6530 123If C<PERL_PV_ESCAPE_FIRSTCHAR> is set then only the first char of the
72d33970 124string will be escaped, regardless of max. If the output is to be in hex,
c8536afa 125then it will be returned as a plain hex
72d33970 126sequence. Thus the output will either be a single char,
c8536afa 127an octal escape sequence, a special escape like C<\n> or a hex value.
3df15adc 128
796b6530
KW
129If C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a C<"%"> and
130not a C<"\\">. This is because regexes very often contain backslashed
131sequences, whereas C<"%"> is not a particularly common character in patterns.
44a2ac75 132
796b6530 133Returns a pointer to the escaped text as held by C<dsv>.
3df15adc
YO
134
135=cut
136*/
ab3bbdeb 137#define PV_ESCAPE_OCTBUFSIZE 32
ddc5bc0f 138
3967c732 139char *
ddc5bc0f 140Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
ab3bbdeb
YO
141 const STRLEN count, const STRLEN max,
142 STRLEN * const escaped, const U32 flags )
143{
61f9802b
AL
144 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
145 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
44a2ac75 146 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
ab3bbdeb
YO
147 STRLEN wrote = 0; /* chars written so far */
148 STRLEN chsize = 0; /* size of data to be written */
149 STRLEN readsize = 1; /* size of data just read */
e5860534 150 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this UTF-8 */
ddc5bc0f 151 const char *pv = str;
61f9802b 152 const char * const end = pv + count; /* end of string */
44a2ac75 153 octbuf[0] = esc;
ab3bbdeb 154
7918f24d
NC
155 PERL_ARGS_ASSERT_PV_ESCAPE;
156
4420a417 157 if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
7fddd944 158 /* This won't alter the UTF-8 flag */
ed0faf2e 159 SvPVCLEAR(dsv);
7fddd944 160 }
ab3bbdeb 161
ddc5bc0f 162 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
ab3bbdeb
YO
163 isuni = 1;
164
165 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) {
4b88fb76 166 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv;
ab3bbdeb
YO
167 const U8 c = (U8)u & 0xFF;
168
681f01c2
KW
169 if ( ( u > 255 )
170 || (flags & PERL_PV_ESCAPE_ALL)
0eb335df 171 || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM))))
681f01c2 172 {
ab3bbdeb
YO
173 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
174 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
175 "%"UVxf, u);
176 else
177 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
0eb335df
BF
178 ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
179 ? "%cx%02"UVxf
180 : "%cx{%02"UVxf"}", esc, u);
181
ab3bbdeb
YO
182 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
183 chsize = 1;
184 } else {
44a2ac75
YO
185 if ( (c == dq) || (c == esc) || !isPRINT(c) ) {
186 chsize = 2;
ab3bbdeb 187 switch (c) {
44a2ac75 188
924ba076 189 case '\\' : /* FALLTHROUGH */
44a2ac75
YO
190 case '%' : if ( c == esc ) {
191 octbuf[1] = esc;
192 } else {
193 chsize = 1;
194 }
195 break;
3df15adc
YO
196 case '\v' : octbuf[1] = 'v'; break;
197 case '\t' : octbuf[1] = 't'; break;
198 case '\r' : octbuf[1] = 'r'; break;
199 case '\n' : octbuf[1] = 'n'; break;
200 case '\f' : octbuf[1] = 'f'; break;
44a2ac75 201 case '"' :
ab3bbdeb 202 if ( dq == '"' )
3df15adc 203 octbuf[1] = '"';
ab3bbdeb
YO
204 else
205 chsize = 1;
44a2ac75 206 break;
3df15adc 207 default:
0eb335df
BF
208 if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
209 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
210 isuni ? "%cx{%02"UVxf"}" : "%cx%02"UVxf,
211 esc, u);
212 }
213 else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
ab3bbdeb 214 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75
YO
215 "%c%03o", esc, c);
216 else
ab3bbdeb 217 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75 218 "%c%o", esc, c);
ab3bbdeb
YO
219 }
220 } else {
44a2ac75 221 chsize = 1;
ab3bbdeb 222 }
44a2ac75
YO
223 }
224 if ( max && (wrote + chsize > max) ) {
225 break;
ab3bbdeb 226 } else if (chsize > 1) {
4420a417
YO
227 if (dsv)
228 sv_catpvn(dsv, octbuf, chsize);
44a2ac75 229 wrote += chsize;
3df15adc 230 } else {
951cbe24
KW
231 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes
232 can be appended raw to the dsv. If dsv happens to be
7fddd944
NC
233 UTF-8 then we need catpvf to upgrade them for us.
234 Or add a new API call sv_catpvc(). Think about that name, and
235 how to keep it clear that it's unlike the s of catpvs, which is
951cbe24 236 really an array of octets, not a string. */
4420a417
YO
237 if (dsv)
238 Perl_sv_catpvf( aTHX_ dsv, "%c", c);
3df15adc
YO
239 wrote++;
240 }
ab3bbdeb
YO
241 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR )
242 break;
3967c732 243 }
ab3bbdeb
YO
244 if (escaped != NULL)
245 *escaped= pv - str;
4420a417 246 return dsv ? SvPVX(dsv) : NULL;
ab3bbdeb
YO
247}
248/*
87cea99e 249=for apidoc pv_pretty
ab3bbdeb
YO
250
251Converts a string into something presentable, handling escaping via
796b6530 252C<pv_escape()> and supporting quoting and ellipses.
ab3bbdeb 253
796b6530 254If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be
72d33970 255double quoted with any double quotes in the string escaped. Otherwise
796b6530 256if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
ab3bbdeb 257angle brackets.
6cba11c8 258
796b6530 259If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in
95b611b0 260string were output then an ellipsis C<...> will be appended to the
72d33970 261string. Note that this happens AFTER it has been quoted.
6cba11c8 262
796b6530
KW
263If C<start_color> is non-null then it will be inserted after the opening
264quote (if there is one) but before the escaped text. If C<end_color>
ab3bbdeb 265is non-null then it will be inserted after the escaped text but before
95b611b0 266any quotes or ellipses.
ab3bbdeb 267
796b6530 268Returns a pointer to the prettified text as held by C<dsv>.
6cba11c8 269
ab3bbdeb
YO
270=cut
271*/
272
273char *
ddc5bc0f
YO
274Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
275 const STRLEN max, char const * const start_color, char const * const end_color,
ab3bbdeb
YO
276 const U32 flags )
277{
3602166e
FC
278 const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
279 (flags & PERL_PV_PRETTY_LTGT) ? "<>" : NULL);
ab3bbdeb 280 STRLEN escaped;
4420a417
YO
281 STRLEN max_adjust= 0;
282 STRLEN orig_cur;
7918f24d
NC
283
284 PERL_ARGS_ASSERT_PV_PRETTY;
285
881a015e 286 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
4420a417 287 /* This won't alter the UTF-8 flag */
ed0faf2e 288 SvPVCLEAR(dsv);
881a015e 289 }
4420a417 290 orig_cur= SvCUR(dsv);
881a015e 291
4420a417
YO
292 if ( quotes )
293 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]);
ab3bbdeb
YO
294
295 if ( start_color != NULL )
76f68e9b 296 sv_catpv(dsv, start_color);
4420a417
YO
297
298 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
299 if (quotes)
300 max_adjust += 2;
301 assert(max > max_adjust);
302 pv_escape( NULL, str, count, max - max_adjust, &escaped, flags );
303 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
304 max_adjust += 3;
305 assert(max > max_adjust);
306 }
307
308 pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR );
309
ab3bbdeb 310 if ( end_color != NULL )
76f68e9b 311 sv_catpv(dsv, end_color);
ab3bbdeb 312
4420a417
YO
313 if ( quotes )
314 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]);
ab3bbdeb 315
95b611b0 316 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) )
76f68e9b 317 sv_catpvs(dsv, "...");
4420a417
YO
318
319 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) {
320 while( SvCUR(dsv) - orig_cur < max )
321 sv_catpvs(dsv," ");
322 }
ab3bbdeb 323
3df15adc
YO
324 return SvPVX(dsv);
325}
326
327/*
328=for apidoc pv_display
329
3df15adc 330Similar to
3967c732 331
3df15adc
YO
332 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE);
333
334except that an additional "\0" will be appended to the string when
335len > cur and pv[cur] is "\0".
336
337Note that the final string may be up to 7 chars longer than pvlim.
338
339=cut
340*/
341
342char *
343Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
344{
7918f24d
NC
345 PERL_ARGS_ASSERT_PV_DISPLAY;
346
ddc5bc0f 347 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
3df15adc 348 if (len > cur && pv[cur] == '\0')
76f68e9b 349 sv_catpvs( dsv, "\\0");
e6abe6d8
JH
350 return SvPVX(dsv);
351}
352
353char *
864dbfa3 354Perl_sv_peek(pTHX_ SV *sv)
3967c732 355{
27da23d5 356 dVAR;
aec46f14 357 SV * const t = sv_newmortal();
3967c732 358 int unref = 0;
5357ca29 359 U32 type;
3967c732 360
ed0faf2e 361 SvPVCLEAR(t);
3967c732
JD
362 retry:
363 if (!sv) {
364 sv_catpv(t, "VOID");
365 goto finish;
366 }
8ee91b45
YO
367 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') {
368 /* detect data corruption under memory poisoning */
3967c732
JD
369 sv_catpv(t, "WILD");
370 goto finish;
371 }
7996736c 372 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
3967c732
JD
373 if (sv == &PL_sv_undef) {
374 sv_catpv(t, "SV_UNDEF");
375 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
376 SVs_GMG|SVs_SMG|SVs_RMG)) &&
377 SvREADONLY(sv))
378 goto finish;
379 }
380 else if (sv == &PL_sv_no) {
381 sv_catpv(t, "SV_NO");
382 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
383 SVs_GMG|SVs_SMG|SVs_RMG)) &&
384 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
385 SVp_POK|SVp_NOK)) &&
386 SvCUR(sv) == 0 &&
659c4b96 387 SvNVX(sv) == 0.0)
3967c732
JD
388 goto finish;
389 }
7996736c 390 else if (sv == &PL_sv_yes) {
3967c732
JD
391 sv_catpv(t, "SV_YES");
392 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
393 SVs_GMG|SVs_SMG|SVs_RMG)) &&
394 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
395 SVp_POK|SVp_NOK)) &&
396 SvCUR(sv) == 1 &&
b15aece3 397 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
659c4b96 398 SvNVX(sv) == 1.0)
3967c732 399 goto finish;
7996736c
MHM
400 }
401 else {
402 sv_catpv(t, "SV_PLACEHOLDER");
403 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
404 SVs_GMG|SVs_SMG|SVs_RMG)) &&
405 SvREADONLY(sv))
406 goto finish;
3967c732
JD
407 }
408 sv_catpv(t, ":");
409 }
410 else if (SvREFCNT(sv) == 0) {
411 sv_catpv(t, "(");
412 unref++;
413 }
a3b4c9c6
DM
414 else if (DEBUG_R_TEST_) {
415 int is_tmp = 0;
e8eb279c 416 SSize_t ix;
a3b4c9c6
DM
417 /* is this SV on the tmps stack? */
418 for (ix=PL_tmps_ix; ix>=0; ix--) {
419 if (PL_tmps_stack[ix] == sv) {
420 is_tmp = 1;
421 break;
422 }
423 }
d5a163ad
DM
424 if (is_tmp || SvREFCNT(sv) > 1) {
425 Perl_sv_catpvf(aTHX_ t, "<");
426 if (SvREFCNT(sv) > 1)
427 Perl_sv_catpvf(aTHX_ t, "%"UVuf, (UV)SvREFCNT(sv));
428 if (is_tmp)
429 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
430 Perl_sv_catpvf(aTHX_ t, ">");
431 }
04932ac8
DM
432 }
433
3967c732
JD
434 if (SvROK(sv)) {
435 sv_catpv(t, "\\");
436 if (SvCUR(t) + unref > 10) {
b162af07 437 SvCUR_set(t, unref + 3);
3967c732
JD
438 *SvEND(t) = '\0';
439 sv_catpv(t, "...");
440 goto finish;
441 }
ad64d0ec 442 sv = SvRV(sv);
3967c732
JD
443 goto retry;
444 }
5357ca29
NC
445 type = SvTYPE(sv);
446 if (type == SVt_PVCV) {
0eb335df
BF
447 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
448 GV* gvcv = CvGV(sv);
c53e4eb5 449 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
0eb335df
BF
450 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
451 : "");
3967c732 452 goto finish;
5357ca29
NC
453 } else if (type < SVt_LAST) {
454 sv_catpv(t, svshorttypenames[type]);
3967c732 455
5357ca29
NC
456 if (type == SVt_NULL)
457 goto finish;
458 } else {
459 sv_catpv(t, "FREED");
3967c732 460 goto finish;
3967c732
JD
461 }
462
463 if (SvPOKp(sv)) {
b15aece3 464 if (!SvPVX_const(sv))
3967c732
JD
465 sv_catpv(t, "(null)");
466 else {
17605be7 467 SV * const tmp = newSVpvs("");
3967c732 468 sv_catpv(t, "(");
5115136b
DM
469 if (SvOOK(sv)) {
470 STRLEN delta;
471 SvOOK_offset(sv, delta);
472 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
473 }
b15aece3 474 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
32639b87 475 if (SvUTF8(sv))
b2ff9928 476 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
e9569a7a 477 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
c728cb41 478 UNI_DISPLAY_QQ));
17605be7 479 SvREFCNT_dec_NN(tmp);
3967c732
JD
480 }
481 }
482 else if (SvNOKp(sv)) {
67d796ae 483 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
1779d84d 484 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv));
67d796ae 485 RESTORE_LC_NUMERIC_UNDERLYING();
3967c732 486 }
57def98f 487 else if (SvIOKp(sv)) {
cf2093f6 488 if (SvIsUV(sv))
57def98f 489 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv));
cf2093f6 490 else
57def98f 491 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv));
25da4f38 492 }
3967c732
JD
493 else
494 sv_catpv(t, "()");
2ef28da1 495
3967c732 496 finish:
61f9802b
AL
497 while (unref--)
498 sv_catpv(t, ")");
9adb2837 499 if (TAINTING_get && sv && SvTAINTED(sv))
59b714e2 500 sv_catpv(t, " [tainted]");
8b6b16e7 501 return SvPV_nolen(t);
3967c732
JD
502}
503
36b1c95c
MH
504/*
505=head1 Debugging Utilities
506*/
507
508void
509Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
510{
511 va_list args;
512 PERL_ARGS_ASSERT_DUMP_INDENT;
513 va_start(args, pat);
514 dump_vindent(level, file, pat, &args);
515 va_end(args);
516}
517
518void
519Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
520{
36b1c95c
MH
521 PERL_ARGS_ASSERT_DUMP_VINDENT;
522 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
523 PerlIO_vprintf(file, pat, *args);
524}
525
526/*
527=for apidoc dump_all
528
529Dumps the entire optree of the current program starting at C<PL_main_root> to
72d33970
FC
530C<STDERR>. Also dumps the optrees for all visible subroutines in
531C<PL_defstash>.
36b1c95c
MH
532
533=cut
534*/
535
536void
537Perl_dump_all(pTHX)
538{
539 dump_all_perl(FALSE);
540}
541
542void
543Perl_dump_all_perl(pTHX_ bool justperl)
544{
36b1c95c
MH
545 PerlIO_setlinebuf(Perl_debug_log);
546 if (PL_main_root)
547 op_dump(PL_main_root);
548 dump_packsubs_perl(PL_defstash, justperl);
549}
550
551/*
552=for apidoc dump_packsubs
553
554Dumps the optrees for all visible subroutines in C<stash>.
555
556=cut
557*/
558
559void
560Perl_dump_packsubs(pTHX_ const HV *stash)
561{
562 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
563 dump_packsubs_perl(stash, FALSE);
564}
565
566void
567Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
568{
36b1c95c
MH
569 I32 i;
570
571 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
572
573 if (!HvARRAY(stash))
574 return;
575 for (i = 0; i <= (I32) HvMAX(stash); i++) {
576 const HE *entry;
577 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
66103581
DM
578 GV * gv = (GV *)HeVAL(entry);
579 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
580 /* unfake a fake GV */
581 (void)CvGV(SvRV(gv));
36b1c95c
MH
582 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
583 continue;
584 if (GvCVu(gv))
585 dump_sub_perl(gv, justperl);
586 if (GvFORM(gv))
587 dump_form(gv);
588 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
589 const HV * const hv = GvHV(gv);
590 if (hv && (hv != PL_defstash))
591 dump_packsubs_perl(hv, justperl); /* nested package */
592 }
593 }
594 }
595}
596
597void
598Perl_dump_sub(pTHX_ const GV *gv)
599{
600 PERL_ARGS_ASSERT_DUMP_SUB;
601 dump_sub_perl(gv, FALSE);
602}
603
604void
605Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
606{
0eb335df
BF
607 STRLEN len;
608 SV * const sv = newSVpvs_flags("", SVs_TEMP);
609 SV *tmpsv;
610 const char * name;
36b1c95c
MH
611
612 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
613
614 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
615 return;
616
0eb335df 617 tmpsv = newSVpvs_flags("", SVs_TEMP);
36b1c95c 618 gv_fullname3(sv, gv, NULL);
0eb335df
BF
619 name = SvPV_const(sv, len);
620 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
621 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
36b1c95c
MH
622 if (CvISXSUB(GvCV(gv)))
623 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
624 PTR2UV(CvXSUB(GvCV(gv))),
625 (int)CvXSUBANY(GvCV(gv)).any_i32);
626 else if (CvROOT(GvCV(gv)))
627 op_dump(CvROOT(GvCV(gv)));
628 else
629 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
630}
631
632void
633Perl_dump_form(pTHX_ const GV *gv)
634{
635 SV * const sv = sv_newmortal();
636
637 PERL_ARGS_ASSERT_DUMP_FORM;
638
639 gv_fullname3(sv, gv, NULL);
640 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
641 if (CvROOT(GvFORM(gv)))
642 op_dump(CvROOT(GvFORM(gv)));
643 else
644 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
645}
646
647void
648Perl_dump_eval(pTHX)
649{
36b1c95c
MH
650 op_dump(PL_eval_root);
651}
652
3967c732 653void
6867be6d 654Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
3967c732
JD
655{
656 char ch;
657
7918f24d
NC
658 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
659
8efda520 660 if (!pm)
3967c732 661 return;
3967c732
JD
662 if (pm->op_pmflags & PMf_ONCE)
663 ch = '?';
664 else
665 ch = '/';
aaa362c4 666 if (PM_GETRE(pm))
f87fee25
FC
667 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n",
668 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch,
3967c732
JD
669 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
670 else
cea2e8a9 671 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
5012eebe
DM
672
673 if (pm->op_type == OP_SPLIT)
674 Perl_dump_indent(aTHX_ level, file, "TARGOFF/GV = 0x%"UVxf"\n",
675 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
676 else {
677 if (pm->op_pmreplrootu.op_pmreplroot) {
678 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
679 op_dump(pm->op_pmreplrootu.op_pmreplroot);
680 }
3967c732 681 }
5012eebe 682
68e2671b 683 if (pm->op_code_list) {
867940b8
DM
684 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
685 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
686 do_op_dump(level, file, pm->op_code_list);
687 }
688 else
689 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
690 PTR2UV(pm->op_code_list));
68e2671b 691 }
07bc277f 692 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
4199688e 693 SV * const tmpsv = pm_description(pm);
b15aece3 694 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
5f954473 695 SvREFCNT_dec_NN(tmpsv);
3967c732 696 }
3967c732
JD
697}
698
a0c2f4dd
NC
699const struct flag_to_name pmflags_flags_names[] = {
700 {PMf_CONST, ",CONST"},
701 {PMf_KEEP, ",KEEP"},
702 {PMf_GLOBAL, ",GLOBAL"},
703 {PMf_CONTINUE, ",CONTINUE"},
704 {PMf_RETAINT, ",RETAINT"},
705 {PMf_EVAL, ",EVAL"},
706 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
d63c20f2 707 {PMf_HAS_CV, ",HAS_CV"},
2a92a973
DM
708 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
709 {PMf_IS_QR, ",IS_QR"}
a0c2f4dd
NC
710};
711
b9ac451d 712static SV *
4199688e
AL
713S_pm_description(pTHX_ const PMOP *pm)
714{
715 SV * const desc = newSVpvs("");
61f9802b 716 const REGEXP * const regex = PM_GETRE(pm);
4199688e
AL
717 const U32 pmflags = pm->op_pmflags;
718
7918f24d
NC
719 PERL_ARGS_ASSERT_PM_DESCRIPTION;
720
4199688e
AL
721 if (pmflags & PMf_ONCE)
722 sv_catpv(desc, ",ONCE");
c737faaf
YO
723#ifdef USE_ITHREADS
724 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
725 sv_catpv(desc, ":USED");
726#else
727 if (pmflags & PMf_USED)
728 sv_catpv(desc, ":USED");
729#endif
c737faaf 730
68d4833d 731 if (regex) {
284167a5 732 if (RX_ISTAINTED(regex))
68d4833d 733 sv_catpv(desc, ",TAINTED");
07bc277f 734 if (RX_CHECK_SUBSTR(regex)) {
e3e400ec 735 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
68d4833d 736 sv_catpv(desc, ",SCANFIRST");
07bc277f 737 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
68d4833d
AB
738 sv_catpv(desc, ",ALL");
739 }
dbc200c5
YO
740 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
741 sv_catpv(desc, ",SKIPWHITE");
4199688e 742 }
68d4833d 743
a0c2f4dd 744 append_flags(desc, pmflags, pmflags_flags_names);
4199688e
AL
745 return desc;
746}
747
3967c732 748void
864dbfa3 749Perl_pmop_dump(pTHX_ PMOP *pm)
3967c732
JD
750{
751 do_pmop_dump(0, Perl_debug_log, pm);
79072805
LW
752}
753
b6f05621
DM
754/* Return a unique integer to represent the address of op o.
755 * If it already exists in PL_op_sequence, just return it;
756 * otherwise add it.
757 * *** Note that this isn't thread-safe */
294b3b39 758
2814eb74 759STATIC UV
0bd48802 760S_sequence_num(pTHX_ const OP *o)
2814eb74 761{
27da23d5 762 dVAR;
2814eb74
PJ
763 SV *op,
764 **seq;
93524f2b 765 const char *key;
2814eb74 766 STRLEN len;
b6f05621
DM
767 if (!o)
768 return 0;
c0fd1b42 769 op = newSVuv(PTR2UV(o));
b6f05621 770 sv_2mortal(op);
93524f2b 771 key = SvPV_const(op, len);
b6f05621
DM
772 if (!PL_op_sequence)
773 PL_op_sequence = newHV();
774 seq = hv_fetch(PL_op_sequence, key, len, 0);
775 if (seq)
776 return SvUV(*seq);
777 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
778 return PL_op_seq;
2814eb74
PJ
779}
780
f3574cc6
DM
781
782
783
784
a0c2f4dd
NC
785const struct flag_to_name op_flags_names[] = {
786 {OPf_KIDS, ",KIDS"},
787 {OPf_PARENS, ",PARENS"},
a0c2f4dd
NC
788 {OPf_REF, ",REF"},
789 {OPf_MOD, ",MOD"},
65cccc5e 790 {OPf_STACKED, ",STACKED"},
a0c2f4dd
NC
791 {OPf_SPECIAL, ",SPECIAL"}
792};
793
75a6ad4a 794
79072805 795void
6867be6d 796Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
79072805 797{
2814eb74 798 UV seq;
e15d5972
AL
799 const OPCODE optype = o->op_type;
800
7918f24d
NC
801 PERL_ARGS_ASSERT_DO_OP_DUMP;
802
cea2e8a9 803 Perl_dump_indent(aTHX_ level, file, "{\n");
3967c732 804 level++;
0bd48802 805 seq = sequence_num(o);
2814eb74 806 if (seq)
f5992bc4 807 PerlIO_printf(file, "%-4"UVuf, seq);
93a17b20 808 else
b6f05621 809 PerlIO_printf(file, "????");
c8db6e60
JH
810 PerlIO_printf(file,
811 "%*sTYPE = %s ===> ",
53e06cf0 812 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
2814eb74 813 if (o->op_next)
b6f05621
DM
814 PerlIO_printf(file,
815 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
666ea192 816 sequence_num(o->op_next));
79072805 817 else
e75ab6ad 818 PerlIO_printf(file, "NULL\n");
11343788 819 if (o->op_targ) {
e15d5972 820 if (optype == OP_NULL) {
cea2e8a9 821 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
ae7d165c 822 }
8990e307 823 else
894356b3 824 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
8990e307 825 }
748a9306 826#ifdef DUMPADDR
57def98f 827 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
79072805 828#endif
a7fd8ef6 829
760f8c06
DM
830 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
831 SV * const tmpsv = newSVpvs("");
832 switch (o->op_flags & OPf_WANT) {
833 case OPf_WANT_VOID:
834 sv_catpv(tmpsv, ",VOID");
835 break;
836 case OPf_WANT_SCALAR:
837 sv_catpv(tmpsv, ",SCALAR");
838 break;
839 case OPf_WANT_LIST:
840 sv_catpv(tmpsv, ",LIST");
841 break;
842 default:
843 sv_catpv(tmpsv, ",UNKNOWN");
844 break;
845 }
846 append_flags(tmpsv, o->op_flags, op_flags_names);
847 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
848 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
849 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
850 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
87b5a8b9 851 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
760f8c06
DM
852 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
853 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
854 }
855
856 if (o->op_private) {
f3574cc6
DM
857 U16 oppriv = o->op_private;
858 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
859 SV * tmpsv = NULL;
860
861 if (op_ix != -1) {
862 U16 stop = 0;
863 tmpsv = newSVpvs("");
864 for (; !stop; op_ix++) {
865 U16 entry = PL_op_private_bitdefs[op_ix];
866 U16 bit = (entry >> 2) & 7;
867 U16 ix = entry >> 5;
868
869 stop = (entry & 1);
870
871 if (entry & 2) {
872 /* bitfield */
873 I16 const *p = &PL_op_private_bitfields[ix];
874 U16 bitmin = (U16) *p++;
875 I16 label = *p++;
876 I16 enum_label;
877 U16 mask = 0;
878 U16 i;
879 U16 val;
880
881 for (i = bitmin; i<= bit; i++)
882 mask |= (1<<i);
883 bit = bitmin;
884 val = (oppriv & mask);
885
886 if ( label != -1
887 && PL_op_private_labels[label] == '-'
888 && PL_op_private_labels[label+1] == '\0'
889 )
890 /* display as raw number */
891 continue;
892
893 oppriv -= val;
894 val >>= bit;
895 enum_label = -1;
896 while (*p != -1) {
897 if (val == *p++) {
898 enum_label = *p;
899 break;
900 }
901 p++;
902 }
903 if (val == 0 && enum_label == -1)
904 /* don't display anonymous zero values */
905 continue;
906
907 sv_catpv(tmpsv, ",");
908 if (label != -1) {
909 sv_catpv(tmpsv, &PL_op_private_labels[label]);
910 sv_catpv(tmpsv, "=");
911 }
95268469
DM
912 if (enum_label == -1)
913 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)val);
914 else
915 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
f3574cc6
DM
916
917 }
918 else {
919 /* bit flag */
920 if ( oppriv & (1<<bit)
921 && !(PL_op_private_labels[ix] == '-'
922 && PL_op_private_labels[ix+1] == '\0'))
923 {
924 oppriv -= (1<<bit);
925 sv_catpv(tmpsv, ",");
926 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
927 }
760f8c06 928 }
760f8c06 929 }
f3574cc6
DM
930 if (oppriv) {
931 sv_catpv(tmpsv, ",");
932 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
760f8c06
DM
933 }
934 }
f3574cc6 935 if (tmpsv && SvCUR(tmpsv)) {
760f8c06
DM
936 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
937 } else
938 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
939 (UV)oppriv);
940 }
941
e15d5972 942 switch (optype) {
971a9dd3 943 case OP_AELEMFAST:
93a17b20 944 case OP_GVSV:
79072805 945 case OP_GV:
971a9dd3 946#ifdef USE_ITHREADS
c803eecc 947 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
971a9dd3 948#else
1640e9f0 949 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
38c076c7 950 if (cSVOPo->op_sv) {
0eb335df
BF
951 STRLEN len;
952 const char * name;
953 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
954 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
159b6efe 955 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
0eb335df 956 name = SvPV_const(tmpsv, len);
8b6b16e7 957 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
0eb335df 958 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
38c076c7
DM
959 }
960 else
961 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
378cc40b 962 }
971a9dd3 963#endif
79072805 964 break;
fedf30e1
DM
965
966 case OP_MULTIDEREF:
967 {
968 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
969 UV i, count = items[-1].uv;
970
971 Perl_dump_indent(aTHX_ level, file, "ARGS = \n");
972 for (i=0; i < count; i++)
973 Perl_dump_indent(aTHX_ level+1, file, "%"UVuf" => 0x%"UVxf"\n",
974 i, items[i].uv);
1e9f2263 975 break;
fedf30e1
DM
976 }
977
79072805 978 case OP_CONST:
996c9baa 979 case OP_HINTSEVAL:
f5d5a27c 980 case OP_METHOD_NAMED:
7d6c333c 981 case OP_METHOD_SUPER:
810bd8b7 982 case OP_METHOD_REDIR:
983 case OP_METHOD_REDIR_SUPER:
b6a15bc5
DM
984#ifndef USE_ITHREADS
985 /* with ITHREADS, consts are stored in the pad, and the right pad
986 * may not be active here, so skip */
b46e009d 987 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
b6a15bc5 988#endif
79072805 989 break;
5e412b02
FC
990 case OP_NULL:
991 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
992 break;
993 /* FALLTHROUGH */
93a17b20
LW
994 case OP_NEXTSTATE:
995 case OP_DBSTATE:
57843af0 996 if (CopLINE(cCOPo))
f5992bc4 997 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
9d98dee5 998 (UV)CopLINE(cCOPo));
0eb335df
BF
999 if (CopSTASHPV(cCOPo)) {
1000 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1001 HV *stash = CopSTASH(cCOPo);
1002 const char * const hvname = HvNAME_get(stash);
1003
ed094faf 1004 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
0eb335df
BF
1005 generic_pv_escape(tmpsv, hvname,
1006 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1007 }
1008 if (CopLABEL(cCOPo)) {
1009 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1010 STRLEN label_len;
1011 U32 label_flags;
1012 const char *label = CopLABEL_len_flags(cCOPo,
1013 &label_len, &label_flags);
1014 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1015 generic_pv_escape( tmpsv, label, label_len,
1016 (label_flags & SVf_UTF8)));
1017 }
7fa99c80 1018 Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
947a9e0f 1019 (unsigned int)cCOPo->cop_seq);
79072805
LW
1020 break;
1021 case OP_ENTERLOOP:
cea2e8a9 1022 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
11343788 1023 if (cLOOPo->op_redoop)
f5992bc4 1024 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
79072805 1025 else
3967c732 1026 PerlIO_printf(file, "DONE\n");
cea2e8a9 1027 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
11343788 1028 if (cLOOPo->op_nextop)
f5992bc4 1029 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
79072805 1030 else
3967c732 1031 PerlIO_printf(file, "DONE\n");
cea2e8a9 1032 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
11343788 1033 if (cLOOPo->op_lastop)
f5992bc4 1034 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
79072805 1035 else
3967c732 1036 PerlIO_printf(file, "DONE\n");
79072805
LW
1037 break;
1038 case OP_COND_EXPR:
1a67a97c 1039 case OP_RANGE:
a0d0e21e 1040 case OP_MAPWHILE:
79072805
LW
1041 case OP_GREPWHILE:
1042 case OP_OR:
1043 case OP_AND:
cea2e8a9 1044 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
11343788 1045 if (cLOGOPo->op_other)
f5992bc4 1046 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
79072805 1047 else
3967c732 1048 PerlIO_printf(file, "DONE\n");
79072805 1049 break;
5012eebe 1050 case OP_SPLIT:
79072805 1051 case OP_MATCH:
8782bef2 1052 case OP_QR:
79072805 1053 case OP_SUBST:
3967c732 1054 do_pmop_dump(level, file, cPMOPo);
79072805 1055 break;
7934575e
GS
1056 case OP_LEAVE:
1057 case OP_LEAVEEVAL:
1058 case OP_LEAVESUB:
1059 case OP_LEAVESUBLV:
1060 case OP_LEAVEWRITE:
1061 case OP_SCOPE:
1062 if (o->op_private & OPpREFCOUNTED)
1063 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1064 break;
a0d0e21e
LW
1065 default:
1066 break;
79072805 1067 }
11343788 1068 if (o->op_flags & OPf_KIDS) {
79072805 1069 OP *kid;
e6dae479 1070 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3967c732 1071 do_op_dump(level, file, kid);
8d063cd8 1072 }
cea2e8a9 1073 Perl_dump_indent(aTHX_ level-1, file, "}\n");
3967c732
JD
1074}
1075
36b1c95c
MH
1076/*
1077=for apidoc op_dump
1078
1079Dumps the optree starting at OP C<o> to C<STDERR>.
1080
1081=cut
1082*/
1083
3967c732 1084void
6867be6d 1085Perl_op_dump(pTHX_ const OP *o)
3967c732 1086{
7918f24d 1087 PERL_ARGS_ASSERT_OP_DUMP;
3967c732 1088 do_op_dump(0, Perl_debug_log, o);
8d063cd8
LW
1089}
1090
8adcabd8 1091void
864dbfa3 1092Perl_gv_dump(pTHX_ GV *gv)
378cc40b 1093{
0eb335df
BF
1094 STRLEN len;
1095 const char* name;
1096 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1097
79072805 1098 if (!gv) {
760ac839 1099 PerlIO_printf(Perl_debug_log, "{}\n");
378cc40b
LW
1100 return;
1101 }
8990e307 1102 sv = sv_newmortal();
760ac839 1103 PerlIO_printf(Perl_debug_log, "{\n");
bd61b366 1104 gv_fullname3(sv, gv, NULL);
0eb335df
BF
1105 name = SvPV_const(sv, len);
1106 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1107 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
79072805 1108 if (gv != GvEGV(gv)) {
bd61b366 1109 gv_efullname3(sv, GvEGV(gv), NULL);
0eb335df
BF
1110 name = SvPV_const(sv, len);
1111 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1112 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
8adcabd8 1113 }
38d7fd8b 1114 (void)PerlIO_putc(Perl_debug_log, '\n');
cea2e8a9 1115 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
8d063cd8
LW
1116}
1117
14befaf4 1118
afe38520 1119/* map magic types to the symbolic names
14befaf4
DM
1120 * (with the PERL_MAGIC_ prefixed stripped)
1121 */
1122
27da23d5 1123static const struct { const char type; const char *name; } magic_names[] = {
16bc0f48 1124#include "mg_names.inc"
516a5887 1125 /* this null string terminates the list */
b9ac451d 1126 { 0, NULL },
14befaf4
DM
1127};
1128
8adcabd8 1129void
6867be6d 1130Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
8d063cd8 1131{
7918f24d
NC
1132 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1133
3967c732 1134 for (; mg; mg = mg->mg_moremagic) {
b900a521
JH
1135 Perl_dump_indent(aTHX_ level, file,
1136 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
3967c732 1137 if (mg->mg_virtual) {
bfed75c6 1138 const MGVTBL * const v = mg->mg_virtual;
2d1f1fe5
NC
1139 if (v >= PL_magic_vtables
1140 && v < PL_magic_vtables + magic_vtable_max) {
1141 const U32 i = v - PL_magic_vtables;
1142 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1143 }
3967c732 1144 else
b900a521 1145 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
3967c732
JD
1146 }
1147 else
cea2e8a9 1148 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
8d063cd8 1149
3967c732 1150 if (mg->mg_private)
cea2e8a9 1151 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
3967c732 1152
14befaf4
DM
1153 {
1154 int n;
c445ea15 1155 const char *name = NULL;
27da23d5 1156 for (n = 0; magic_names[n].name; n++) {
14befaf4
DM
1157 if (mg->mg_type == magic_names[n].type) {
1158 name = magic_names[n].name;
1159 break;
1160 }
1161 }
1162 if (name)
1163 Perl_dump_indent(aTHX_ level, file,
1164 " MG_TYPE = PERL_MAGIC_%s\n", name);
1165 else
1166 Perl_dump_indent(aTHX_ level, file,
1167 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1168 }
3967c732
JD
1169
1170 if (mg->mg_flags) {
cea2e8a9 1171 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
cb50f42d
YST
1172 if (mg->mg_type == PERL_MAGIC_envelem &&
1173 mg->mg_flags & MGf_TAINTEDDIR)
cea2e8a9 1174 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
4c02285a
FR
1175 if (mg->mg_type == PERL_MAGIC_regex_global &&
1176 mg->mg_flags & MGf_MINMATCH)
1177 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
3967c732 1178 if (mg->mg_flags & MGf_REFCOUNTED)
cea2e8a9 1179 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1180 if (mg->mg_flags & MGf_GSKIP)
cea2e8a9 1181 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
4c02285a
FR
1182 if (mg->mg_flags & MGf_COPY)
1183 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1184 if (mg->mg_flags & MGf_DUP)
1185 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1186 if (mg->mg_flags & MGf_LOCAL)
1187 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
25fdce4a
FC
1188 if (mg->mg_type == PERL_MAGIC_regex_global &&
1189 mg->mg_flags & MGf_BYTES)
1190 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
3967c732
JD
1191 }
1192 if (mg->mg_obj) {
4c02285a 1193 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
28d8d7f4
YO
1194 PTR2UV(mg->mg_obj));
1195 if (mg->mg_type == PERL_MAGIC_qr) {
07bc277f 1196 REGEXP* const re = (REGEXP *)mg->mg_obj;
61f9802b 1197 SV * const dsv = sv_newmortal();
866c78d1 1198 const char * const s
4c02285a 1199 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
28d8d7f4 1200 60, NULL, NULL,
95b611b0 1201 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
3c8556c3 1202 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
28d8d7f4 1203 );
6483fb35
RGS
1204 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1205 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
07bc277f 1206 (IV)RX_REFCNT(re));
28d8d7f4
YO
1207 }
1208 if (mg->mg_flags & MGf_REFCOUNTED)
3967c732
JD
1209 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1210 }
1211 if (mg->mg_len)
894356b3 1212 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1213 if (mg->mg_ptr) {
b900a521 1214 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
3967c732 1215 if (mg->mg_len >= 0) {
7e8c5dac 1216 if (mg->mg_type != PERL_MAGIC_utf8) {
17605be7 1217 SV * const sv = newSVpvs("");
7e8c5dac 1218 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
17605be7 1219 SvREFCNT_dec_NN(sv);
7e8c5dac 1220 }
3967c732
JD
1221 }
1222 else if (mg->mg_len == HEf_SVKEY) {
1223 PerlIO_puts(file, " => HEf_SVKEY\n");
ad64d0ec
NC
1224 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1225 maxnest, dumpops, pvlim); /* MG is already +1 */
3967c732
JD
1226 continue;
1227 }
866f9d6c 1228 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
3967c732 1229 else
866f9d6c
FC
1230 PerlIO_puts(
1231 file,
1232 " ???? - " __FILE__
1233 " does not know how to handle this MG_LEN"
1234 );
38d7fd8b 1235 (void)PerlIO_putc(file, '\n');
3967c732 1236 }
7e8c5dac 1237 if (mg->mg_type == PERL_MAGIC_utf8) {
61f9802b 1238 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7e8c5dac
HS
1239 if (cache) {
1240 IV i;
1241 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1242 Perl_dump_indent(aTHX_ level, file,
1243 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1244 i,
1245 (UV)cache[i * 2],
1246 (UV)cache[i * 2 + 1]);
1247 }
1248 }
378cc40b 1249 }
3967c732
JD
1250}
1251
1252void
6867be6d 1253Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1254{
b9ac451d 1255 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732
JD
1256}
1257
1258void
e1ec3a88 1259Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1260{
bfcb3514 1261 const char *hvname;
7918f24d
NC
1262
1263 PERL_ARGS_ASSERT_DO_HV_DUMP;
1264
b900a521 1265 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
bfcb3514 1266 if (sv && (hvname = HvNAME_get(sv)))
d7d51f4b
YO
1267 {
1268 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1269 name which quite legally could contain insane things like tabs, newlines, nulls or
1270 other scary crap - this should produce sane results - except maybe for unicode package
1271 names - but we will wait for someone to file a bug on that - demerphq */
0eb335df
BF
1272 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1273 PerlIO_printf(file, "\t\"%s\"\n",
1274 generic_pv_escape( tmpsv, hvname,
1275 HvNAMELEN(sv), HvNAMEUTF8(sv)));
d7d51f4b 1276 }
79072805 1277 else
38d7fd8b 1278 (void)PerlIO_putc(file, '\n');
3967c732
JD
1279}
1280
1281void
e1ec3a88 1282Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1283{
7918f24d
NC
1284 PERL_ARGS_ASSERT_DO_GV_DUMP;
1285
b900a521 1286 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
0eb335df
BF
1287 if (sv && GvNAME(sv)) {
1288 SV * const tmpsv = newSVpvs("");
1289 PerlIO_printf(file, "\t\"%s\"\n",
1290 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1291 }
c90c0ff4 1292 else
38d7fd8b 1293 (void)PerlIO_putc(file, '\n');
3967c732
JD
1294}
1295
1296void
e1ec3a88 1297Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1298{
7918f24d
NC
1299 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1300
b900a521 1301 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732 1302 if (sv && GvNAME(sv)) {
0eb335df 1303 SV *tmp = newSVpvs_flags("", SVs_TEMP);
bfcb3514 1304 const char *hvname;
0eb335df
BF
1305 HV * const stash = GvSTASH(sv);
1306 PerlIO_printf(file, "\t");
1307 /* TODO might have an extra \" here */
1308 if (stash && (hvname = HvNAME_get(stash))) {
1309 PerlIO_printf(file, "\"%s\" :: \"",
1310 generic_pv_escape(tmp, hvname,
1311 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1312 }
1313 PerlIO_printf(file, "%s\"\n",
1314 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
8d063cd8 1315 }
3967c732 1316 else
38d7fd8b 1317 (void)PerlIO_putc(file, '\n');
3967c732
JD
1318}
1319
a0c2f4dd
NC
1320const struct flag_to_name first_sv_flags_names[] = {
1321 {SVs_TEMP, "TEMP,"},
1322 {SVs_OBJECT, "OBJECT,"},
1323 {SVs_GMG, "GMG,"},
1324 {SVs_SMG, "SMG,"},
1325 {SVs_RMG, "RMG,"},
1326 {SVf_IOK, "IOK,"},
1327 {SVf_NOK, "NOK,"},
1328 {SVf_POK, "POK,"}
1329};
1330
1331const struct flag_to_name second_sv_flags_names[] = {
1332 {SVf_OOK, "OOK,"},
1333 {SVf_FAKE, "FAKE,"},
1334 {SVf_READONLY, "READONLY,"},
fd01b4b7 1335 {SVf_PROTECT, "PROTECT,"},
a0c2f4dd 1336 {SVf_BREAK, "BREAK,"},
a0c2f4dd
NC
1337 {SVp_IOK, "pIOK,"},
1338 {SVp_NOK, "pNOK,"},
1339 {SVp_POK, "pPOK,"}
1340};
1341
ae1f06a1
NC
1342const struct flag_to_name cv_flags_names[] = {
1343 {CVf_ANON, "ANON,"},
1344 {CVf_UNIQUE, "UNIQUE,"},
1345 {CVf_CLONE, "CLONE,"},
1346 {CVf_CLONED, "CLONED,"},
1347 {CVf_CONST, "CONST,"},
1348 {CVf_NODEBUG, "NODEBUG,"},
1349 {CVf_LVALUE, "LVALUE,"},
1350 {CVf_METHOD, "METHOD,"},
cfc1e951 1351 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1352 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1353 {CVf_DYNFILE, "DYNFILE,"},
8fa6a409 1354 {CVf_AUTOLOAD, "AUTOLOAD,"},
e4555ecf 1355 {CVf_HASEVAL, "HASEVAL,"},
bfbc3ad9 1356 {CVf_SLABBED, "SLABBED,"},
bf9a4d2d 1357 {CVf_NAMED, "NAMED,"},
82487b59 1358 {CVf_LEXICAL, "LEXICAL,"},
31d45e0c 1359 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC
1360};
1361
1362const struct flag_to_name hv_flags_names[] = {
1363 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1364 {SVphv_LAZYDEL, "LAZYDEL,"},
1365 {SVphv_HASKFLAGS, "HASKFLAGS,"},
45eaf8af 1366 {SVf_AMAGIC, "OVERLOAD,"},
ae1f06a1
NC
1367 {SVphv_CLONEABLE, "CLONEABLE,"}
1368};
1369
1370const struct flag_to_name gp_flags_names[] = {
1371 {GVf_INTRO, "INTRO,"},
1372 {GVf_MULTI, "MULTI,"},
1373 {GVf_ASSUMECV, "ASSUMECV,"},
ae1f06a1
NC
1374};
1375
1376const struct flag_to_name gp_flags_imported_names[] = {
1377 {GVf_IMPORTED_SV, " SV"},
1378 {GVf_IMPORTED_AV, " AV"},
1379 {GVf_IMPORTED_HV, " HV"},
1380 {GVf_IMPORTED_CV, " CV"},
1381};
1382
0d331aaf
YO
1383/* NOTE: this structure is mostly duplicative of one generated by
1384 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1385 * the two. - Yves */
e3e400ec 1386const struct flag_to_name regexp_extflags_names[] = {
d63e6659
DM
1387 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1388 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1389 {RXf_PMf_FOLD, "PMf_FOLD,"},
1390 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
334afb3e 1391 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
d63e6659 1392 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
41d7c59e 1393 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
8e1490ee 1394 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
dbc200c5 1395 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
d63e6659 1396 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
d63e6659
DM
1397 {RXf_CHECK_ALL, "CHECK_ALL,"},
1398 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1399 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1400 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1401 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
dbc200c5 1402 {RXf_SPLIT, "SPLIT,"},
d63e6659
DM
1403 {RXf_COPY_DONE, "COPY_DONE,"},
1404 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1405 {RXf_TAINTED, "TAINTED,"},
1406 {RXf_START_ONLY, "START_ONLY,"},
dbc200c5 1407 {RXf_SKIPWHITE, "SKIPWHITE,"},
d63e6659
DM
1408 {RXf_WHITE, "WHITE,"},
1409 {RXf_NULL, "NULL,"},
1410};
1411
0d331aaf
YO
1412/* NOTE: this structure is mostly duplicative of one generated by
1413 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1414 * the two. - Yves */
e3e400ec
YO
1415const struct flag_to_name regexp_core_intflags_names[] = {
1416 {PREGf_SKIP, "SKIP,"},
0d331aaf
YO
1417 {PREGf_IMPLICIT, "IMPLICIT,"},
1418 {PREGf_NAUGHTY, "NAUGHTY,"},
e3e400ec
YO
1419 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1420 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
0d331aaf 1421 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
e3e400ec 1422 {PREGf_NOSCAN, "NOSCAN,"},
58430ea8
YO
1423 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1424 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
8e1490ee
YO
1425 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1426 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1427 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
e3e400ec
YO
1428};
1429
c24d0595
DM
1430/* Perl_do_sv_dump():
1431 *
1432 * level: amount to indent the output
1433 * sv: the object to dump
1434 * nest: the current level of recursion
1435 * maxnest: the maximum allowed level of recursion
1436 * dumpops: if true, also dump the ops associated with a CV
1437 * pvlim: limit on the length of any strings that are output
1438 * */
1439
3967c732 1440void
864dbfa3 1441Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1442{
cea89e20 1443 SV *d;
e1ec3a88 1444 const char *s;
3967c732
JD
1445 U32 flags;
1446 U32 type;
1447
7918f24d
NC
1448 PERL_ARGS_ASSERT_DO_SV_DUMP;
1449
3967c732 1450 if (!sv) {
cea2e8a9 1451 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1452 return;
378cc40b 1453 }
2ef28da1 1454
3967c732
JD
1455 flags = SvFLAGS(sv);
1456 type = SvTYPE(sv);
79072805 1457
e0bbf362
DM
1458 /* process general SV flags */
1459
cea89e20 1460 d = Perl_newSVpvf(aTHX_
57def98f 1461 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
56431972 1462 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS
1463 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1464 (int)(PL_dumpindent*level), "");
8d063cd8 1465
0f94cb1f 1466 if ((flags & SVs_PADSTALE))
9a214eec 1467 sv_catpv(d, "PADSTALE,");
0f94cb1f 1468 if ((flags & SVs_PADTMP))
9a214eec 1469 sv_catpv(d, "PADTMP,");
a0c2f4dd 1470 append_flags(d, flags, first_sv_flags_names);
810b8aa5
GS
1471 if (flags & SVf_ROK) {
1472 sv_catpv(d, "ROK,");
1473 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1474 }
45eaf8af 1475 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
a0c2f4dd 1476 append_flags(d, flags, second_sv_flags_names);
7db6405c
FC
1477 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1478 && type != SVt_PVAV) {
1ccdb730
NC
1479 if (SvPCS_IMPORTED(sv))
1480 sv_catpv(d, "PCS_IMPORTED,");
1481 else
9660f481 1482 sv_catpv(d, "SCREAM,");
1ccdb730 1483 }
3967c732 1484
e0bbf362
DM
1485 /* process type-specific SV flags */
1486
3967c732
JD
1487 switch (type) {
1488 case SVt_PVCV:
1489 case SVt_PVFM:
ae1f06a1 1490 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD
1491 break;
1492 case SVt_PVHV:
ae1f06a1 1493 append_flags(d, flags, hv_flags_names);
3967c732 1494 break;
926fc7b6
DM
1495 case SVt_PVGV:
1496 case SVt_PVLV:
1497 if (isGV_with_GP(sv)) {
ae1f06a1 1498 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1499 }
926fc7b6 1500 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD
1501 sv_catpv(d, "IMPORT");
1502 if (GvIMPORTED(sv) == GVf_IMPORTED)
1503 sv_catpv(d, "ALL,");
1504 else {
1505 sv_catpv(d, "(");
ae1f06a1 1506 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
3967c732
JD
1507 sv_catpv(d, " ),");
1508 }
1509 }
924ba076 1510 /* FALLTHROUGH */
25da4f38 1511 default:
6432a58a 1512 do_uv:
69c678eb 1513 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1514 break;
addd1794 1515 case SVt_PVMG:
c13a5c80
NC
1516 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1517 if (SvVALID(sv)) sv_catpv(d, "VALID,");
6432a58a 1518 goto do_uv;
11ca45c0
NC
1519 case SVt_PVAV:
1520 break;
3967c732 1521 }
86f0d186
NC
1522 /* SVphv_SHAREKEYS is also 0x20000000 */
1523 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1524 sv_catpv(d, "UTF8");
3967c732 1525
b162af07
SP
1526 if (*(SvEND(d) - 1) == ',') {
1527 SvCUR_set(d, SvCUR(d) - 1);
1528 SvPVX(d)[SvCUR(d)] = '\0';
1529 }
3967c732 1530 sv_catpv(d, ")");
b15aece3 1531 s = SvPVX_const(d);
3967c732 1532
e0bbf362
DM
1533 /* dump initial SV details */
1534
fd0854ff 1535#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1536 Perl_dump_indent(aTHX_ level, file,
cd676548 1537 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
fd0854ff
DM
1538 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1539 sv->sv_debug_line,
1540 sv->sv_debug_inpad ? "for" : "by",
1541 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1542 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM
1543 sv->sv_debug_serial
1544 );
fd0854ff 1545#endif
cea2e8a9 1546 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM
1547
1548 /* Dump SV type */
1549
5357ca29
NC
1550 if (type < SVt_LAST) {
1551 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1552
1553 if (type == SVt_NULL) {
5f954473 1554 SvREFCNT_dec_NN(d);
5357ca29
NC
1555 return;
1556 }
1557 } else {
faccc32b 1558 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
5f954473 1559 SvREFCNT_dec_NN(d);
3967c732
JD
1560 return;
1561 }
e0bbf362
DM
1562
1563 /* Dump general SV fields */
1564
27bd069f 1565 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC
1566 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1567 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1568 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1569 if (SvIsUV(sv)
765f542d 1570 )
57def98f 1571 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1572 else
57def98f 1573 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
38d7fd8b 1574 (void)PerlIO_putc(file, '\n');
3967c732 1575 }
e0bbf362 1576
0f94cb1f 1577 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1578 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1579 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1580 || type == SVt_NV) {
67d796ae 1581 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
88cb8500 1582 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
67d796ae 1583 RESTORE_LC_NUMERIC_UNDERLYING();
3967c732 1584 }
e0bbf362 1585
3967c732 1586 if (SvROK(sv)) {
57def98f 1587 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732
JD
1588 if (nest < maxnest)
1589 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1590 }
e0bbf362 1591
cea89e20 1592 if (type < SVt_PV) {
5f954473 1593 SvREFCNT_dec_NN(d);
3967c732 1594 return;
cea89e20 1595 }
e0bbf362 1596
5a3c7349
FC
1597 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1598 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
8d919b0a
FC
1599 const bool re = isREGEXP(sv);
1600 const char * const ptr =
1601 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1602 if (ptr) {
69240efd 1603 STRLEN delta;
7a4bba22 1604 if (SvOOK(sv)) {
69240efd 1605 SvOOK_offset(sv, delta);
7a4bba22 1606 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
5186cc12 1607 (UV) delta);
69240efd
NC
1608 } else {
1609 delta = 0;
7a4bba22 1610 }
8d919b0a 1611 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
7a4bba22
NC
1612 if (SvOOK(sv)) {
1613 PerlIO_printf(file, "( %s . ) ",
8d919b0a 1614 pv_display(d, ptr - delta, delta, 0,
7a4bba22
NC
1615 pvlim));
1616 }
ad3f05ad
KW
1617 if (type == SVt_INVLIST) {
1618 PerlIO_printf(file, "\n");
1619 /* 4 blanks indents 2 beyond the PV, etc */
1620 _invlist_dump(file, level, " ", sv);
1621 }
1622 else {
685bfc3c
KW
1623 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1624 re ? 0 : SvLEN(sv),
1625 pvlim));
1626 if (SvUTF8(sv)) /* the 6? \x{....} */
1627 PerlIO_printf(file, " [UTF8 \"%s\"]",
1628 sv_uni_display(d, sv, 6 * SvCUR(sv),
1629 UNI_DISPLAY_QQ));
1630 PerlIO_printf(file, "\n");
ad3f05ad 1631 }
57def98f 1632 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
8d919b0a
FC
1633 if (!re)
1634 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1635 (IV)SvLEN(sv));
93c10d60 1636#ifdef PERL_COPY_ON_WRITE
db2c6cb3
FC
1637 if (SvIsCOW(sv) && SvLEN(sv))
1638 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1639 CowREFCNT(sv));
1640#endif
3967c732
JD
1641 }
1642 else
cea2e8a9 1643 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1644 }
e0bbf362 1645
3967c732 1646 if (type >= SVt_PVMG) {
0f94cb1f 1647 if (SvMAGIC(sv))
8530ff28 1648 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
3967c732
JD
1649 if (SvSTASH(sv))
1650 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC
1651
1652 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
c13a5c80
NC
1653 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1654 }
3967c732 1655 }
e0bbf362
DM
1656
1657 /* Dump type-specific SV fields */
1658
3967c732 1659 switch (type) {
3967c732 1660 case SVt_PVAV:
57def98f 1661 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1662 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f
JH
1663 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1664 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732
JD
1665 }
1666 else
38d7fd8b 1667 (void)PerlIO_putc(file, '\n');
57def98f
JH
1668 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1669 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
ed0faf2e 1670 SvPVCLEAR(d);
11ca45c0
NC
1671 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1672 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP
1673 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1674 SvCUR(d) ? SvPVX_const(d) + 1 : "");
476fafda 1675 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
c70927a6 1676 SSize_t count;
476fafda
DM
1677 SV **svp = AvARRAY(MUTABLE_AV(sv));
1678 for (count = 0;
1679 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1680 count++, svp++)
1681 {
1682 SV* const elt = *svp;
57def98f 1683 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
476fafda 1684 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
3967c732
JD
1685 }
1686 }
1687 break;
5d27ee4a
DD
1688 case SVt_PVHV: {
1689 U32 usedkeys;
0c22a733
DM
1690 if (SvOOK(sv)) {
1691 struct xpvhv_aux *const aux = HvAUX(sv);
1692 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1693 (UV)aux->xhv_aux_flags);
1694 }
57def98f 1695 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
5d27ee4a
DD
1696 usedkeys = HvUSEDKEYS(sv);
1697 if (HvARRAY(sv) && usedkeys) {
3967c732
JD
1698 /* Show distribution of HEs in the ARRAY */
1699 int freq[200];
c3caa5c3 1700#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
3967c732
JD
1701 int i;
1702 int max = 0;
5d27ee4a 1703 U32 pow2 = 2, keys = usedkeys;
65202027 1704 NV theoret, sum = 0;
3967c732
JD
1705
1706 PerlIO_printf(file, " (");
1707 Zero(freq, FREQ_MAX + 1, int);
eb160463 1708 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL
1709 HE* h;
1710 int count = 0;
3967c732
JD
1711 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1712 count++;
1713 if (count > FREQ_MAX)
1714 count = FREQ_MAX;
1715 freq[count]++;
1716 if (max < count)
1717 max = count;
1718 }
1719 for (i = 0; i <= max; i++) {
1720 if (freq[i]) {
1721 PerlIO_printf(file, "%d%s:%d", i,
1722 (i == FREQ_MAX) ? "+" : "",
1723 freq[i]);
1724 if (i != max)
1725 PerlIO_printf(file, ", ");
1726 }
1727 }
38d7fd8b 1728 (void)PerlIO_putc(file, ')');
b8fa94d8
MG
1729 /* The "quality" of a hash is defined as the total number of
1730 comparisons needed to access every element once, relative
1731 to the expected number needed for a random hash.
1732
1733 The total number of comparisons is equal to the sum of
e76cd0fa
AMS
1734 the squares of the number of entries in each bucket.
1735 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG
1736 value is
1737 n + n(n-1)/2k
1738 */
1739
3967c732
JD
1740 for (i = max; i > 0; i--) { /* Precision: count down. */
1741 sum += freq[i] * i * i;
1742 }
155aba94 1743 while ((keys = keys >> 1))
3967c732 1744 pow2 = pow2 << 1;
5d27ee4a 1745 theoret = usedkeys;
b8fa94d8 1746 theoret += theoret * (theoret-1)/pow2;
38d7fd8b 1747 (void)PerlIO_putc(file, '\n');
6b4667fc 1748 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732 1749 }
38d7fd8b 1750 (void)PerlIO_putc(file, '\n');
5d27ee4a 1751 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
9faf471a
NC
1752 {
1753 STRLEN count = 0;
1754 HE **ents = HvARRAY(sv);
1755
1756 if (ents) {
1757 HE *const *const last = ents + HvMAX(sv);
1758 count = last + 1 - ents;
1759
1760 do {
1761 if (!*ents)
1762 --count;
1763 } while (++ents <= last);
1764 }
1765
8bf4c401
YO
1766 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1767 (UV)count);
9faf471a 1768 }
57def98f 1769 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
e1a7ec8d
YO
1770 if (SvOOK(sv)) {
1771 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1772 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
6a5b4183 1773#ifdef PERL_HASH_RANDOMIZE_KEYS
e1a7ec8d
YO
1774 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1775 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
6a5b4183 1776 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
e1a7ec8d 1777 }
6a5b4183 1778#endif
38d7fd8b 1779 (void)PerlIO_putc(file, '\n');
e1a7ec8d 1780 }
8d2f4536 1781 {
b9ac451d 1782 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536
NC
1783 if (mg && mg->mg_obj) {
1784 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1785 }
1786 }
bfcb3514 1787 {
b9ac451d 1788 const char * const hvname = HvNAME_get(sv);
0eb335df
BF
1789 if (hvname) {
1790 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1791 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1792 generic_pv_escape( tmpsv, hvname,
1793 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1794 }
bfcb3514 1795 }
86f55936 1796 if (SvOOK(sv)) {
ad64d0ec 1797 AV * const backrefs
85fbaab2 1798 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 1799 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC
1800 if (HvAUX(sv)->xhv_name_count)
1801 Perl_dump_indent(aTHX_
7afc2217
FC
1802 level, file, " NAMECOUNT = %"IVdf"\n",
1803 (IV)HvAUX(sv)->xhv_name_count
67e04715 1804 );
15d9236d 1805 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC
1806 const I32 count = HvAUX(sv)->xhv_name_count;
1807 if (count) {
1808 SV * const names = newSVpvs_flags("", SVs_TEMP);
1809 /* The starting point is the first element if count is
1810 positive and the second element if count is negative. */
1811 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1812 + (count < 0 ? 1 : 0);
1813 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1814 + (count < 0 ? -count : count);
1815 while (hekp < endp) {
8e5993c4 1816 if (*hekp) {
0eb335df
BF
1817 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1818 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1819 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
ec3405c8
NC
1820 } else {
1821 /* This should never happen. */
1822 sv_catpvs(names, ", (null)");
67e04715 1823 }
ec3405c8
NC
1824 ++hekp;
1825 }
67e04715
FC
1826 Perl_dump_indent(aTHX_
1827 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1828 );
1829 }
0eb335df
BF
1830 else {
1831 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1832 const char *const hvename = HvENAME_get(sv);
67e04715 1833 Perl_dump_indent(aTHX_
0eb335df
BF
1834 level, file, " ENAME = \"%s\"\n",
1835 generic_pv_escape(tmp, hvename,
1836 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1837 }
67e04715 1838 }
86f55936
NC
1839 if (backrefs) {
1840 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1841 PTR2UV(backrefs));
ad64d0ec 1842 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC
1843 dumpops, pvlim);
1844 }
7d88e6c4 1845 if (meta) {
0eb335df
BF
1846 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1847 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1848 generic_pv_escape( tmpsv, meta->mro_which->name,
1849 meta->mro_which->length,
1850 (meta->mro_which->kflags & HVhek_UTF8)),
7d88e6c4
NC
1851 PTR2UV(meta->mro_which));
1852 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1853 (UV)meta->cache_gen);
1854 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1855 (UV)meta->pkg_gen);
1856 if (meta->mro_linear_all) {
1857 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1858 PTR2UV(meta->mro_linear_all));
1859 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1860 dumpops, pvlim);
1861 }
1862 if (meta->mro_linear_current) {
1863 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1864 PTR2UV(meta->mro_linear_current));
1865 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1866 dumpops, pvlim);
1867 }
1868 if (meta->mro_nextmethod) {
1869 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1870 PTR2UV(meta->mro_nextmethod));
1871 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1872 dumpops, pvlim);
1873 }
1874 if (meta->isa) {
1875 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1876 PTR2UV(meta->isa));
1877 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1878 dumpops, pvlim);
1879 }
1880 }
86f55936 1881 }
b5698553 1882 if (nest < maxnest) {
cbab3169 1883 HV * const hv = MUTABLE_HV(sv);
b5698553
TH
1884 STRLEN i;
1885 HE *he;
cbab3169 1886
b5698553
TH
1887 if (HvARRAY(hv)) {
1888 int count = maxnest - nest;
1889 for (i=0; i <= HvMAX(hv); i++) {
1890 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1891 U32 hash;
1892 SV * keysv;
1893 const char * keypv;
1894 SV * elt;
7dc86639 1895 STRLEN len;
b5698553
TH
1896
1897 if (count-- <= 0) goto DONEHV;
1898
1899 hash = HeHASH(he);
1900 keysv = hv_iterkeysv(he);
1901 keypv = SvPV_const(keysv, len);
1902 elt = HeVAL(he);
cbab3169 1903
7dc86639
YO
1904 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1905 if (SvUTF8(keysv))
1906 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH
1907 if (HvEITER_get(hv) == he)
1908 PerlIO_printf(file, "[CURRENT] ");
7dc86639
YO
1909 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1910 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1911 }
b5698553
TH
1912 }
1913 DONEHV:;
1914 }
3967c732
JD
1915 }
1916 break;
5d27ee4a 1917 } /* case SVt_PVHV */
e0bbf362 1918
3967c732 1919 case SVt_PVCV:
8fa6a409 1920 if (CvAUTOLOAD(sv)) {
0eb335df
BF
1921 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1922 STRLEN len;
8fa6a409 1923 const char *const name = SvPV_const(sv, len);
0eb335df
BF
1924 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1925 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
8fa6a409
FC
1926 }
1927 if (SvPOK(sv)) {
0eb335df
BF
1928 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1929 const char *const proto = CvPROTO(sv);
1930 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1931 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1932 SvUTF8(sv)));
cbf82dd0 1933 }
924ba076 1934 /* FALLTHROUGH */
3967c732
JD
1935 case SVt_PVFM:
1936 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC
1937 if (!CvISXSUB(sv)) {
1938 if (CvSTART(sv)) {
27604593
DM
1939 if (CvSLABBED(sv))
1940 Perl_dump_indent(aTHX_ level, file,
1941 " SLAB = 0x%"UVxf"\n",
1942 PTR2UV(CvSTART(sv)));
1943 else
1944 Perl_dump_indent(aTHX_ level, file,
d04ba589
NC
1945 " START = 0x%"UVxf" ===> %"IVdf"\n",
1946 PTR2UV(CvSTART(sv)),
1947 (IV)sequence_num(CvSTART(sv)));
1948 }
1949 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1950 PTR2UV(CvROOT(sv)));
1951 if (CvROOT(sv) && dumpops) {
1952 do_op_dump(level+1, file, CvROOT(sv));
1953 }
1954 } else {
126f53f3 1955 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 1956
d04ba589 1957 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099
NC
1958
1959 if (constant) {
1960 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1961 " (CONST SV)\n",
1962 PTR2UV(CvXSUBANY(sv).any_ptr));
1963 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1964 pvlim);
1965 } else {
1966 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1967 (IV)CvXSUBANY(sv).any_i32);
1968 }
1969 }
3610c89f
FC
1970 if (CvNAMED(sv))
1971 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1972 HEK_KEY(CvNAME_HEK((CV *)sv)));
1973 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1974 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
bb02a38f 1975 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 1976 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 1977 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
eacbb379
DD
1978 if (!CvISXSUB(sv)) {
1979 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1980 if (nest < maxnest) {
1981 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1982 }
3967c732 1983 }
eacbb379 1984 else
db6e00bd 1985 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
3967c732 1986 {
b9ac451d 1987 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 1988 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 1989 PTR2UV(outside),
cf2093f6
JH
1990 (!outside ? "null"
1991 : CvANON(outside) ? "ANON"
1992 : (outside == PL_main_cv) ? "MAIN"
1993 : CvUNIQUE(outside) ? "UNIQUE"
b24fda9d
BF
1994 : CvGV(outside) ?
1995 generic_pv_escape(
1996 newSVpvs_flags("", SVs_TEMP),
1997 GvNAME(CvGV(outside)),
1998 GvNAMELEN(CvGV(outside)),
1999 GvNAMEUTF8(CvGV(outside)))
2000 : "UNDEFINED"));
3967c732 2001 }
704b97aa
FC
2002 if (CvOUTSIDE(sv)
2003 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
ad64d0ec 2004 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2005 break;
e0bbf362 2006
926fc7b6
DM
2007 case SVt_PVGV:
2008 case SVt_PVLV:
b9ac451d
AL
2009 if (type == SVt_PVLV) {
2010 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2011 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2012 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2013 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
83f78d1a 2014 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
305b8651 2015 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
b9ac451d
AL
2016 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2017 dumpops, pvlim);
2018 }
8d919b0a 2019 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM
2020 if (!isGV_with_GP(sv))
2021 break;
0eb335df
BF
2022 {
2023 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2024 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2025 generic_pv_escape(tmpsv, GvNAME(sv),
2026 GvNAMELEN(sv),
2027 GvNAMEUTF8(sv)));
2028 }
57def98f 2029 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 2030 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
be108a01 2031 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
57def98f 2032 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c
GS
2033 if (!GvGP(sv))
2034 break;
57def98f
JH
2035 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2036 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2037 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2038 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2040 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2041 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2042 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
008009b0
FC
2043 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
2044 " (%s)\n",
2045 (UV)GvGPFLAGS(sv),
71afaece 2046 "");
57def98f 2047 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 2048 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
3967c732
JD
2049 do_gv_dump (level, file, " EGV", GvEGV(sv));
2050 break;
2051 case SVt_PVIO:
57def98f
JH
2052 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2053 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2054 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2055 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2056 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2057 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2058 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 2059 if (IoTOP_NAME(sv))
cea2e8a9 2060 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC
2061 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2062 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2063 else {
2064 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2065 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC
2066 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2067 maxnest, dumpops, pvlim);
9ba1f565
NC
2068 }
2069 /* Source filters hide things that are not GVs in these three, so let's
2070 be careful out there. */
27533608 2071 if (IoFMT_NAME(sv))
cea2e8a9 2072 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC
2073 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2074 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2075 else {
2076 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2077 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC
2078 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2079 maxnest, dumpops, pvlim);
9ba1f565 2080 }
27533608 2081 if (IoBOTTOM_NAME(sv))
cea2e8a9 2082 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC
2083 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2084 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2085 else {
2086 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2087 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC
2088 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2089 maxnest, dumpops, pvlim);
9ba1f565 2090 }
27533608 2091 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2092 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2093 else
cea2e8a9 2094 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 2095 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732 2096 break;
206ee256 2097 case SVt_REGEXP:
8d919b0a 2098 dumpregexp:
d63e6659 2099 {
8d919b0a 2100 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO
2101
2102#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2103 sv_setpv(d,""); \
e3e400ec 2104 append_flags(d, flags, names); \
ec16d31f
YO
2105 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2106 SvCUR_set(d, SvCUR(d) - 1); \
2107 SvPVX(d)[SvCUR(d)] = '\0'; \
2108 } \
2109} STMT_END
e3e400ec 2110 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
dbc200c5
YO
2111 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2112 (UV)(r->compflags), SvPVX_const(d));
2113
e3e400ec 2114 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
d63e6659 2115 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
dbc200c5
YO
2116 (UV)(r->extflags), SvPVX_const(d));
2117
e3e400ec
YO
2118 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2119 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2120 if (r->engine == &PL_core_reg_engine) {
2121 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2122 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2123 (UV)(r->intflags), SvPVX_const(d));
2124 } else {
2125 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
d63e6659 2126 (UV)(r->intflags));
e3e400ec
YO
2127 }
2128#undef SV_SET_STRINGIFY_REGEXP_FLAGS
d63e6659
DM
2129 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2130 (UV)(r->nparens));
2131 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2132 (UV)(r->lastparen));
2133 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2134 (UV)(r->lastcloseparen));
2135 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2136 (IV)(r->minlen));
2137 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2138 (IV)(r->minlenret));
2139 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2140 (UV)(r->gofs));
2141 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2142 (UV)(r->pre_prefix));
d63e6659
DM
2143 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2144 (IV)(r->sublen));
6502e081
DM
2145 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2146 (IV)(r->suboffset));
2147 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2148 (IV)(r->subcoffset));
d63e6659
DM
2149 if (r->subbeg)
2150 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2151 PTR2UV(r->subbeg),
2152 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2153 else
2154 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
d63e6659
DM
2155 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2156 PTR2UV(r->mother_re));
01ffd0f1
FC
2157 if (nest < maxnest && r->mother_re)
2158 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2159 maxnest, dumpops, pvlim);
d63e6659
DM
2160 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2161 PTR2UV(r->paren_names));
2162 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2163 PTR2UV(r->substrs));
2164 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2165 PTR2UV(r->pprivate));
2166 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2167 PTR2UV(r->offs));
d63c20f2
DM
2168 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2169 PTR2UV(r->qr_anoncv));
db2c6cb3 2170#ifdef PERL_ANY_COW
d63e6659
DM
2171 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2172 PTR2UV(r->saved_copy));
2173#endif
2174 }
206ee256 2175 break;
3967c732 2176 }
5f954473 2177 SvREFCNT_dec_NN(d);
3967c732
JD
2178}
2179
36b1c95c
MH
2180/*
2181=for apidoc sv_dump
2182
2183Dumps the contents of an SV to the C<STDERR> filehandle.
2184
2185For an example of its output, see L<Devel::Peek>.
2186
2187=cut
2188*/
2189
3967c732 2190void
864dbfa3 2191Perl_sv_dump(pTHX_ SV *sv)
3967c732 2192{
7918f24d
NC
2193 PERL_ARGS_ASSERT_SV_DUMP;
2194
d1029faa
JP
2195 if (SvROK(sv))
2196 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2197 else
2198 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2199}
bd16a5f0
IZ
2200
2201int
2202Perl_runops_debug(pTHX)
2203{
2204 if (!PL_op) {
9b387841 2205 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ
2206 return 0;
2207 }
2208
9f3673fb 2209 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2210 do {
75d476e2
S
2211#ifdef PERL_TRACE_OPS
2212 ++PL_op_exec_cnt[PL_op->op_type];
2213#endif
bd16a5f0 2214 if (PL_debug) {
991bab54
DM
2215 ENTER;
2216 SAVETMPS;
b9ac451d 2217 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0
IZ
2218 PerlIO_printf(Perl_debug_log,
2219 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2220 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2221 PTR2UV(*PL_watchaddr));
d6721266
DM
2222 if (DEBUG_s_TEST_) {
2223 if (DEBUG_v_TEST_) {
2224 PerlIO_printf(Perl_debug_log, "\n");
2225 deb_stack_all();
2226 }
2227 else
2228 debstack();
2229 }
2230
2231
bd16a5f0
IZ
2232 if (DEBUG_t_TEST_) debop(PL_op);
2233 if (DEBUG_P_TEST_) debprof(PL_op);
991bab54
DM
2234 FREETMPS;
2235 LEAVE;
bd16a5f0 2236 }
fe83c362 2237
3f6bd23a 2238 PERL_DTRACE_PROBE_OP(PL_op);
16c91539 2239 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2240 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2241 PERL_ASYNC_CHECK();
bd16a5f0
IZ
2242
2243 TAINT_NOT;
2244 return 0;
2245}
2246
f9b02e42
DM
2247
2248/* print the names of the n lexical vars starting at pad offset off */
2249
f9db5646 2250STATIC void
f9b02e42
DM
2251S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2252{
2253 PADNAME *sv;
2254 CV * const cv = deb_curcv(cxstack_ix);
2255 PADNAMELIST *comppad = NULL;
2256 int i;
2257
2258 if (cv) {
2259 PADLIST * const padlist = CvPADLIST(cv);
2260 comppad = PadlistNAMES(padlist);
2261 }
2262 if (paren)
2263 PerlIO_printf(Perl_debug_log, "(");
2264 for (i = 0; i < n; i++) {
2265 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2266 PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2267 else
2268 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2269 (UV)(off+i));
2270 if (i < n - 1)
2271 PerlIO_printf(Perl_debug_log, ",");
2272 }
2273 if (paren)
2274 PerlIO_printf(Perl_debug_log, ")");
2275}
2276
2277
fedf30e1
DM
2278/* append to the out SV, the name of the lexical at offset off in the CV
2279 * cv */
2280
ec48399d 2281static void
fedf30e1
DM
2282S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2283 bool paren, bool is_scalar)
2284{
2285 PADNAME *sv;
2286 PADNAMELIST *namepad = NULL;
2287 int i;
2288
2289 if (cv) {
2290 PADLIST * const padlist = CvPADLIST(cv);
2291 namepad = PadlistNAMES(padlist);
2292 }
2293
2294 if (paren)
2295 sv_catpvs_nomg(out, "(");
2296 for (i = 0; i < n; i++) {
2297 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2298 {
2299 STRLEN cur = SvCUR(out);
26334c4d
FC
2300 Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2301 UTF8fARG(1, PadnameLEN(sv) - 1,
2302 PadnamePV(sv) + 1));
fedf30e1
DM
2303 if (is_scalar)
2304 SvPVX(out)[cur] = '$';
2305 }
2306 else
2307 Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2308 if (i < n - 1)
2309 sv_catpvs_nomg(out, ",");
2310 }
2311 if (paren)
2312 sv_catpvs_nomg(out, "(");
2313}
2314
2315
ec48399d 2316static void
8bbe2fa8 2317S_append_gv_name(pTHX_ GV *gv, SV *out)
fedf30e1
DM
2318{
2319 SV *sv;
2320 if (!gv) {
2321 sv_catpvs_nomg(out, "<NULLGV>");
2322 return;
2323 }
2324 sv = newSV(0);
2325 gv_fullname4(sv, gv, NULL, FALSE);
ac892e4a 2326 Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv));
fedf30e1
DM
2327 SvREFCNT_dec_NN(sv);
2328}
2329
2330#ifdef USE_ITHREADS
dc3c1c70
DM
2331# define ITEM_SV(item) (comppad ? \
2332 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
fedf30e1
DM
2333#else
2334# define ITEM_SV(item) UNOP_AUX_item_sv(item)
2335#endif
2336
2337
2338/* return a temporary SV containing a stringified representation of
48ee9c0e 2339 * the op_aux field of a MULTIDEREF op, associated with CV cv
fedf30e1
DM
2340 */
2341
2342SV*
48ee9c0e 2343Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
fedf30e1
DM
2344{
2345 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2346 UV actions = items->uv;
2347 SV *sv;
2348 bool last = 0;
2349 bool is_hash = FALSE;
2350 int derefs = 0;
ff94d24c 2351 SV *out = newSVpvn_flags("",0,SVs_TEMP);
fedf30e1 2352#ifdef USE_ITHREADS
dc3c1c70
DM
2353 PAD *comppad;
2354
2355 if (cv) {
2356 PADLIST *padlist = CvPADLIST(cv);
2357 comppad = PadlistARRAY(padlist)[1];
2358 }
2359 else
2360 comppad = NULL;
fedf30e1
DM
2361#endif
2362
48ee9c0e 2363 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
fedf30e1
DM
2364
2365 while (!last) {
2366 switch (actions & MDEREF_ACTION_MASK) {
2367
2368 case MDEREF_reload:
2369 actions = (++items)->uv;
2370 continue;
2b5060ae 2371 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2372
2373 case MDEREF_HV_padhv_helem:
2374 is_hash = TRUE;
2b5060ae 2375 /* FALLTHROUGH */
fedf30e1
DM
2376 case MDEREF_AV_padav_aelem:
2377 derefs = 1;
2378 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2379 goto do_elem;
2b5060ae 2380 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2381
2382 case MDEREF_HV_gvhv_helem:
2383 is_hash = TRUE;
2b5060ae 2384 /* FALLTHROUGH */
fedf30e1
DM
2385 case MDEREF_AV_gvav_aelem:
2386 derefs = 1;
dc3c1c70
DM
2387 items++;
2388 sv = ITEM_SV(items);
8bbe2fa8 2389 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2390 goto do_elem;
2b5060ae 2391 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2392
2393 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2394 is_hash = TRUE;
2b5060ae 2395 /* FALLTHROUGH */
fedf30e1 2396 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
dc3c1c70
DM
2397 items++;
2398 sv = ITEM_SV(items);
8bbe2fa8 2399 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2400 goto do_vivify_rv2xv_elem;
2b5060ae 2401 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2402
2403 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2404 is_hash = TRUE;
2b5060ae 2405 /* FALLTHROUGH */
fedf30e1
DM
2406 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2407 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2408 goto do_vivify_rv2xv_elem;
2b5060ae 2409 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2410
2411 case MDEREF_HV_pop_rv2hv_helem:
2412 case MDEREF_HV_vivify_rv2hv_helem:
2413 is_hash = TRUE;
2b5060ae 2414 /* FALLTHROUGH */
fedf30e1
DM
2415 do_vivify_rv2xv_elem:
2416 case MDEREF_AV_pop_rv2av_aelem:
2417 case MDEREF_AV_vivify_rv2av_aelem:
2418 if (!derefs++)
2419 sv_catpvs_nomg(out, "->");
2420 do_elem:
2421 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2422 sv_catpvs_nomg(out, "->");
2423 last = 1;
2424 break;
2425 }
2426
2427 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2428 switch (actions & MDEREF_INDEX_MASK) {
2429 case MDEREF_INDEX_const:
2430 if (is_hash) {
dc3c1c70
DM
2431 items++;
2432 sv = ITEM_SV(items);
2433 if (!sv)
2434 sv_catpvs_nomg(out, "???");
2435 else {
2436 STRLEN cur;
2437 char *s;
2438 s = SvPV(sv, cur);
2439 pv_pretty(out, s, cur, 30,
2440 NULL, NULL,
2441 (PERL_PV_PRETTY_NOCLEAR
2442 |PERL_PV_PRETTY_QUOTE
2443 |PERL_PV_PRETTY_ELLIPSES));
2444 }
fedf30e1
DM
2445 }
2446 else
2447 Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2448 break;
2449 case MDEREF_INDEX_padsv:
2450 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2451 break;
2452 case MDEREF_INDEX_gvsv:
dc3c1c70
DM
2453 items++;
2454 sv = ITEM_SV(items);
8bbe2fa8 2455 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM
2456 break;
2457 }
2458 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2459
2460 if (actions & MDEREF_FLAG_last)
2461 last = 1;
2462 is_hash = FALSE;
2463
2464 break;
2465
2466 default:
2467 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2468 (int)(actions & MDEREF_ACTION_MASK));
2469 last = 1;
2470 break;
2471
2472 } /* switch */
2473
2474 actions >>= MDEREF_SHIFT;
2475 } /* while */
2476 return out;
2477}
2478
2479
bd16a5f0 2480I32
6867be6d 2481Perl_debop(pTHX_ const OP *o)
bd16a5f0 2482{
7918f24d
NC
2483 PERL_ARGS_ASSERT_DEBOP;
2484
1045810a
IZ
2485 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2486 return 0;
2487
bd16a5f0
IZ
2488 Perl_deb(aTHX_ "%s", OP_NAME(o));
2489 switch (o->op_type) {
2490 case OP_CONST:
996c9baa 2491 case OP_HINTSEVAL:
6cefa69e 2492 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2493 * may not be active here, so check.
6cefa69e 2494 * Looks like only during compiling the pads are illegal.
7367e658 2495 */
6cefa69e
RU
2496#ifdef USE_ITHREADS
2497 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2498#endif
7367e658 2499 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ
2500 break;
2501 case OP_GVSV:
2502 case OP_GV:
8333ca1a 2503 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
b9ac451d 2504 SV * const sv = newSV(0);
bd61b366 2505 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2506 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
5f954473 2507 SvREFCNT_dec_NN(sv);
bd16a5f0 2508 }
8333ca1a
FC
2509 else if (cGVOPo_gv) {
2510 SV * const sv = newSV(0);
2511 assert(SvROK(cGVOPo_gv));
2512 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2513 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
ecf05a58 2514 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
8333ca1a
FC
2515 SvREFCNT_dec_NN(sv);
2516 }
bd16a5f0
IZ
2517 else
2518 PerlIO_printf(Perl_debug_log, "(NULL)");
2519 break;
a7fd8ef6 2520
bd16a5f0
IZ
2521 case OP_PADSV:
2522 case OP_PADAV:
2523 case OP_PADHV:
4fa06845 2524 case OP_ARGELEM:
f9b02e42
DM
2525 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2526 break;
fedf30e1 2527
a7fd8ef6 2528 case OP_PADRANGE:
f9b02e42
DM
2529 S_deb_padvar(aTHX_ o->op_targ,
2530 o->op_private & OPpPADRANGE_COUNTMASK, 1);
bd16a5f0 2531 break;
a7fd8ef6 2532
fedf30e1 2533 case OP_MULTIDEREF:
ac892e4a
DM
2534 PerlIO_printf(Perl_debug_log, "(%"SVf")",
2535 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
fedf30e1
DM
2536 break;
2537
bd16a5f0 2538 default:
091ab601 2539 break;
bd16a5f0
IZ
2540 }
2541 PerlIO_printf(Perl_debug_log, "\n");
2542 return 0;
2543}
2544
2545STATIC CV*
dc6240c9 2546S_deb_curcv(pTHX_ I32 ix)
bd16a5f0 2547{
dc6240c9
DM
2548 PERL_SI *si = PL_curstackinfo;
2549 for (; ix >=0; ix--) {
2550 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2551
2552 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2553 return cx->blk_sub.cv;
2554 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2555 return cx->blk_eval.cv;
2556 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2557 return PL_main_cv;
2558 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2559 && si->si_type == PERLSI_SORT)
2560 {
2561 /* fake sort sub; use CV of caller */
2562 si = si->si_prev;
2563 ix = si->si_cxix + 1;
2564 }
2565 }
2566 return NULL;
bd16a5f0
IZ
2567}
2568
2569void
2570Perl_watch(pTHX_ char **addr)
2571{
7918f24d
NC
2572 PERL_ARGS_ASSERT_WATCH;
2573
bd16a5f0
IZ
2574 PL_watchaddr = addr;
2575 PL_watchok = *addr;
2576 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2577 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2578}
2579
2580STATIC void
e1ec3a88 2581S_debprof(pTHX_ const OP *o)
bd16a5f0 2582{
7918f24d
NC
2583 PERL_ARGS_ASSERT_DEBPROF;
2584
61f9802b 2585 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2586 return;
bd16a5f0 2587 if (!PL_profiledata)
a02a5408 2588 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ
2589 ++PL_profiledata[o->op_type];
2590}
2591
2592void
2593Perl_debprofdump(pTHX)
2594{
2595 unsigned i;
2596 if (!PL_profiledata)
2597 return;
2598 for (i = 0; i < MAXO; i++) {
2599 if (PL_profiledata[i])
2600 PerlIO_printf(Perl_debug_log,
2601 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2602 PL_op_name[i]);
2603 }
2604}
66610fdd 2605
3b721df9 2606
66610fdd 2607/*
14d04a33 2608 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2609 */