This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
eliminate SVpbm_VALID flag
[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 */
a5c7cb08 1511 case SVt_PVMG:
25da4f38 1512 default:
69c678eb 1513 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1514 break;
a5c7cb08 1515
11ca45c0
NC
1516 case SVt_PVAV:
1517 break;
3967c732 1518 }
86f0d186
NC
1519 /* SVphv_SHAREKEYS is also 0x20000000 */
1520 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1521 sv_catpv(d, "UTF8");
3967c732 1522
b162af07
SP
1523 if (*(SvEND(d) - 1) == ',') {
1524 SvCUR_set(d, SvCUR(d) - 1);
1525 SvPVX(d)[SvCUR(d)] = '\0';
1526 }
3967c732 1527 sv_catpv(d, ")");
b15aece3 1528 s = SvPVX_const(d);
3967c732 1529
e0bbf362
DM
1530 /* dump initial SV details */
1531
fd0854ff 1532#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1533 Perl_dump_indent(aTHX_ level, file,
cd676548 1534 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
fd0854ff
DM
1535 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1536 sv->sv_debug_line,
1537 sv->sv_debug_inpad ? "for" : "by",
1538 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1539 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM
1540 sv->sv_debug_serial
1541 );
fd0854ff 1542#endif
cea2e8a9 1543 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM
1544
1545 /* Dump SV type */
1546
5357ca29
NC
1547 if (type < SVt_LAST) {
1548 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1549
1550 if (type == SVt_NULL) {
5f954473 1551 SvREFCNT_dec_NN(d);
5357ca29
NC
1552 return;
1553 }
1554 } else {
faccc32b 1555 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
5f954473 1556 SvREFCNT_dec_NN(d);
3967c732
JD
1557 return;
1558 }
e0bbf362
DM
1559
1560 /* Dump general SV fields */
1561
27bd069f 1562 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC
1563 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1564 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1565 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1566 if (SvIsUV(sv)
765f542d 1567 )
57def98f 1568 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1569 else
57def98f 1570 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
38d7fd8b 1571 (void)PerlIO_putc(file, '\n');
3967c732 1572 }
e0bbf362 1573
0f94cb1f 1574 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1575 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1576 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1577 || type == SVt_NV) {
67d796ae 1578 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
88cb8500 1579 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
67d796ae 1580 RESTORE_LC_NUMERIC_UNDERLYING();
3967c732 1581 }
e0bbf362 1582
3967c732 1583 if (SvROK(sv)) {
57def98f 1584 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732
JD
1585 if (nest < maxnest)
1586 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1587 }
e0bbf362 1588
cea89e20 1589 if (type < SVt_PV) {
5f954473 1590 SvREFCNT_dec_NN(d);
3967c732 1591 return;
cea89e20 1592 }
e0bbf362 1593
5a3c7349
FC
1594 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1595 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
8d919b0a
FC
1596 const bool re = isREGEXP(sv);
1597 const char * const ptr =
1598 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1599 if (ptr) {
69240efd 1600 STRLEN delta;
7a4bba22 1601 if (SvOOK(sv)) {
69240efd 1602 SvOOK_offset(sv, delta);
7a4bba22 1603 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
5186cc12 1604 (UV) delta);
69240efd
NC
1605 } else {
1606 delta = 0;
7a4bba22 1607 }
8d919b0a 1608 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
7a4bba22
NC
1609 if (SvOOK(sv)) {
1610 PerlIO_printf(file, "( %s . ) ",
8d919b0a 1611 pv_display(d, ptr - delta, delta, 0,
7a4bba22
NC
1612 pvlim));
1613 }
ad3f05ad
KW
1614 if (type == SVt_INVLIST) {
1615 PerlIO_printf(file, "\n");
1616 /* 4 blanks indents 2 beyond the PV, etc */
1617 _invlist_dump(file, level, " ", sv);
1618 }
1619 else {
685bfc3c
KW
1620 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1621 re ? 0 : SvLEN(sv),
1622 pvlim));
1623 if (SvUTF8(sv)) /* the 6? \x{....} */
1624 PerlIO_printf(file, " [UTF8 \"%s\"]",
1625 sv_uni_display(d, sv, 6 * SvCUR(sv),
1626 UNI_DISPLAY_QQ));
1627 PerlIO_printf(file, "\n");
ad3f05ad 1628 }
57def98f 1629 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
8d919b0a
FC
1630 if (!re)
1631 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1632 (IV)SvLEN(sv));
93c10d60 1633#ifdef PERL_COPY_ON_WRITE
db2c6cb3
FC
1634 if (SvIsCOW(sv) && SvLEN(sv))
1635 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1636 CowREFCNT(sv));
1637#endif
3967c732
JD
1638 }
1639 else
cea2e8a9 1640 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1641 }
e0bbf362 1642
3967c732 1643 if (type >= SVt_PVMG) {
0f94cb1f 1644 if (SvMAGIC(sv))
8530ff28 1645 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
3967c732
JD
1646 if (SvSTASH(sv))
1647 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC
1648
1649 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
c13a5c80
NC
1650 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1651 }
3967c732 1652 }
e0bbf362
DM
1653
1654 /* Dump type-specific SV fields */
1655
3967c732 1656 switch (type) {
3967c732 1657 case SVt_PVAV:
57def98f 1658 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1659 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f
JH
1660 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1661 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732
JD
1662 }
1663 else
38d7fd8b 1664 (void)PerlIO_putc(file, '\n');
57def98f
JH
1665 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1666 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
ed0faf2e 1667 SvPVCLEAR(d);
11ca45c0
NC
1668 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1669 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP
1670 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1671 SvCUR(d) ? SvPVX_const(d) + 1 : "");
476fafda 1672 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
c70927a6 1673 SSize_t count;
476fafda
DM
1674 SV **svp = AvARRAY(MUTABLE_AV(sv));
1675 for (count = 0;
1676 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1677 count++, svp++)
1678 {
1679 SV* const elt = *svp;
57def98f 1680 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
476fafda 1681 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
3967c732
JD
1682 }
1683 }
1684 break;
5d27ee4a
DD
1685 case SVt_PVHV: {
1686 U32 usedkeys;
0c22a733
DM
1687 if (SvOOK(sv)) {
1688 struct xpvhv_aux *const aux = HvAUX(sv);
1689 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1690 (UV)aux->xhv_aux_flags);
1691 }
57def98f 1692 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
5d27ee4a
DD
1693 usedkeys = HvUSEDKEYS(sv);
1694 if (HvARRAY(sv) && usedkeys) {
3967c732
JD
1695 /* Show distribution of HEs in the ARRAY */
1696 int freq[200];
c3caa5c3 1697#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
3967c732
JD
1698 int i;
1699 int max = 0;
5d27ee4a 1700 U32 pow2 = 2, keys = usedkeys;
65202027 1701 NV theoret, sum = 0;
3967c732
JD
1702
1703 PerlIO_printf(file, " (");
1704 Zero(freq, FREQ_MAX + 1, int);
eb160463 1705 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL
1706 HE* h;
1707 int count = 0;
3967c732
JD
1708 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1709 count++;
1710 if (count > FREQ_MAX)
1711 count = FREQ_MAX;
1712 freq[count]++;
1713 if (max < count)
1714 max = count;
1715 }
1716 for (i = 0; i <= max; i++) {
1717 if (freq[i]) {
1718 PerlIO_printf(file, "%d%s:%d", i,
1719 (i == FREQ_MAX) ? "+" : "",
1720 freq[i]);
1721 if (i != max)
1722 PerlIO_printf(file, ", ");
1723 }
1724 }
38d7fd8b 1725 (void)PerlIO_putc(file, ')');
b8fa94d8
MG
1726 /* The "quality" of a hash is defined as the total number of
1727 comparisons needed to access every element once, relative
1728 to the expected number needed for a random hash.
1729
1730 The total number of comparisons is equal to the sum of
e76cd0fa
AMS
1731 the squares of the number of entries in each bucket.
1732 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG
1733 value is
1734 n + n(n-1)/2k
1735 */
1736
3967c732
JD
1737 for (i = max; i > 0; i--) { /* Precision: count down. */
1738 sum += freq[i] * i * i;
1739 }
155aba94 1740 while ((keys = keys >> 1))
3967c732 1741 pow2 = pow2 << 1;
5d27ee4a 1742 theoret = usedkeys;
b8fa94d8 1743 theoret += theoret * (theoret-1)/pow2;
38d7fd8b 1744 (void)PerlIO_putc(file, '\n');
6b4667fc 1745 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732 1746 }
38d7fd8b 1747 (void)PerlIO_putc(file, '\n');
5d27ee4a 1748 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
9faf471a
NC
1749 {
1750 STRLEN count = 0;
1751 HE **ents = HvARRAY(sv);
1752
1753 if (ents) {
1754 HE *const *const last = ents + HvMAX(sv);
1755 count = last + 1 - ents;
1756
1757 do {
1758 if (!*ents)
1759 --count;
1760 } while (++ents <= last);
1761 }
1762
8bf4c401
YO
1763 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1764 (UV)count);
9faf471a 1765 }
57def98f 1766 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
e1a7ec8d
YO
1767 if (SvOOK(sv)) {
1768 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1769 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
6a5b4183 1770#ifdef PERL_HASH_RANDOMIZE_KEYS
e1a7ec8d
YO
1771 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1772 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
6a5b4183 1773 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
e1a7ec8d 1774 }
6a5b4183 1775#endif
38d7fd8b 1776 (void)PerlIO_putc(file, '\n');
e1a7ec8d 1777 }
8d2f4536 1778 {
b9ac451d 1779 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536
NC
1780 if (mg && mg->mg_obj) {
1781 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1782 }
1783 }
bfcb3514 1784 {
b9ac451d 1785 const char * const hvname = HvNAME_get(sv);
0eb335df
BF
1786 if (hvname) {
1787 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1788 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1789 generic_pv_escape( tmpsv, hvname,
1790 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1791 }
bfcb3514 1792 }
86f55936 1793 if (SvOOK(sv)) {
ad64d0ec 1794 AV * const backrefs
85fbaab2 1795 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 1796 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC
1797 if (HvAUX(sv)->xhv_name_count)
1798 Perl_dump_indent(aTHX_
7afc2217
FC
1799 level, file, " NAMECOUNT = %"IVdf"\n",
1800 (IV)HvAUX(sv)->xhv_name_count
67e04715 1801 );
15d9236d 1802 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC
1803 const I32 count = HvAUX(sv)->xhv_name_count;
1804 if (count) {
1805 SV * const names = newSVpvs_flags("", SVs_TEMP);
1806 /* The starting point is the first element if count is
1807 positive and the second element if count is negative. */
1808 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1809 + (count < 0 ? 1 : 0);
1810 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1811 + (count < 0 ? -count : count);
1812 while (hekp < endp) {
8e5993c4 1813 if (*hekp) {
0eb335df
BF
1814 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1815 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1816 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
ec3405c8
NC
1817 } else {
1818 /* This should never happen. */
1819 sv_catpvs(names, ", (null)");
67e04715 1820 }
ec3405c8
NC
1821 ++hekp;
1822 }
67e04715
FC
1823 Perl_dump_indent(aTHX_
1824 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1825 );
1826 }
0eb335df
BF
1827 else {
1828 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1829 const char *const hvename = HvENAME_get(sv);
67e04715 1830 Perl_dump_indent(aTHX_
0eb335df
BF
1831 level, file, " ENAME = \"%s\"\n",
1832 generic_pv_escape(tmp, hvename,
1833 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1834 }
67e04715 1835 }
86f55936
NC
1836 if (backrefs) {
1837 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1838 PTR2UV(backrefs));
ad64d0ec 1839 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC
1840 dumpops, pvlim);
1841 }
7d88e6c4 1842 if (meta) {
0eb335df
BF
1843 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1844 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1845 generic_pv_escape( tmpsv, meta->mro_which->name,
1846 meta->mro_which->length,
1847 (meta->mro_which->kflags & HVhek_UTF8)),
7d88e6c4
NC
1848 PTR2UV(meta->mro_which));
1849 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1850 (UV)meta->cache_gen);
1851 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1852 (UV)meta->pkg_gen);
1853 if (meta->mro_linear_all) {
1854 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1855 PTR2UV(meta->mro_linear_all));
1856 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1857 dumpops, pvlim);
1858 }
1859 if (meta->mro_linear_current) {
1860 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1861 PTR2UV(meta->mro_linear_current));
1862 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1863 dumpops, pvlim);
1864 }
1865 if (meta->mro_nextmethod) {
1866 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1867 PTR2UV(meta->mro_nextmethod));
1868 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1869 dumpops, pvlim);
1870 }
1871 if (meta->isa) {
1872 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1873 PTR2UV(meta->isa));
1874 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1875 dumpops, pvlim);
1876 }
1877 }
86f55936 1878 }
b5698553 1879 if (nest < maxnest) {
cbab3169 1880 HV * const hv = MUTABLE_HV(sv);
b5698553
TH
1881 STRLEN i;
1882 HE *he;
cbab3169 1883
b5698553
TH
1884 if (HvARRAY(hv)) {
1885 int count = maxnest - nest;
1886 for (i=0; i <= HvMAX(hv); i++) {
1887 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1888 U32 hash;
1889 SV * keysv;
1890 const char * keypv;
1891 SV * elt;
7dc86639 1892 STRLEN len;
b5698553
TH
1893
1894 if (count-- <= 0) goto DONEHV;
1895
1896 hash = HeHASH(he);
1897 keysv = hv_iterkeysv(he);
1898 keypv = SvPV_const(keysv, len);
1899 elt = HeVAL(he);
cbab3169 1900
7dc86639
YO
1901 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1902 if (SvUTF8(keysv))
1903 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH
1904 if (HvEITER_get(hv) == he)
1905 PerlIO_printf(file, "[CURRENT] ");
7dc86639
YO
1906 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1907 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1908 }
b5698553
TH
1909 }
1910 DONEHV:;
1911 }
3967c732
JD
1912 }
1913 break;
5d27ee4a 1914 } /* case SVt_PVHV */
e0bbf362 1915
3967c732 1916 case SVt_PVCV:
8fa6a409 1917 if (CvAUTOLOAD(sv)) {
0eb335df
BF
1918 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1919 STRLEN len;
8fa6a409 1920 const char *const name = SvPV_const(sv, len);
0eb335df
BF
1921 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1922 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
8fa6a409
FC
1923 }
1924 if (SvPOK(sv)) {
0eb335df
BF
1925 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1926 const char *const proto = CvPROTO(sv);
1927 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1928 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1929 SvUTF8(sv)));
cbf82dd0 1930 }
924ba076 1931 /* FALLTHROUGH */
3967c732
JD
1932 case SVt_PVFM:
1933 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC
1934 if (!CvISXSUB(sv)) {
1935 if (CvSTART(sv)) {
27604593
DM
1936 if (CvSLABBED(sv))
1937 Perl_dump_indent(aTHX_ level, file,
1938 " SLAB = 0x%"UVxf"\n",
1939 PTR2UV(CvSTART(sv)));
1940 else
1941 Perl_dump_indent(aTHX_ level, file,
d04ba589
NC
1942 " START = 0x%"UVxf" ===> %"IVdf"\n",
1943 PTR2UV(CvSTART(sv)),
1944 (IV)sequence_num(CvSTART(sv)));
1945 }
1946 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1947 PTR2UV(CvROOT(sv)));
1948 if (CvROOT(sv) && dumpops) {
1949 do_op_dump(level+1, file, CvROOT(sv));
1950 }
1951 } else {
126f53f3 1952 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 1953
d04ba589 1954 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099
NC
1955
1956 if (constant) {
1957 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1958 " (CONST SV)\n",
1959 PTR2UV(CvXSUBANY(sv).any_ptr));
1960 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1961 pvlim);
1962 } else {
1963 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1964 (IV)CvXSUBANY(sv).any_i32);
1965 }
1966 }
3610c89f
FC
1967 if (CvNAMED(sv))
1968 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1969 HEK_KEY(CvNAME_HEK((CV *)sv)));
1970 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1971 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
bb02a38f 1972 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 1973 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 1974 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
eacbb379
DD
1975 if (!CvISXSUB(sv)) {
1976 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1977 if (nest < maxnest) {
1978 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1979 }
3967c732 1980 }
eacbb379 1981 else
db6e00bd 1982 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
3967c732 1983 {
b9ac451d 1984 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 1985 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 1986 PTR2UV(outside),
cf2093f6
JH
1987 (!outside ? "null"
1988 : CvANON(outside) ? "ANON"
1989 : (outside == PL_main_cv) ? "MAIN"
1990 : CvUNIQUE(outside) ? "UNIQUE"
b24fda9d
BF
1991 : CvGV(outside) ?
1992 generic_pv_escape(
1993 newSVpvs_flags("", SVs_TEMP),
1994 GvNAME(CvGV(outside)),
1995 GvNAMELEN(CvGV(outside)),
1996 GvNAMEUTF8(CvGV(outside)))
1997 : "UNDEFINED"));
3967c732 1998 }
704b97aa
FC
1999 if (CvOUTSIDE(sv)
2000 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
ad64d0ec 2001 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2002 break;
e0bbf362 2003
926fc7b6
DM
2004 case SVt_PVGV:
2005 case SVt_PVLV:
b9ac451d
AL
2006 if (type == SVt_PVLV) {
2007 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2008 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2009 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2010 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
83f78d1a 2011 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
305b8651 2012 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
b9ac451d
AL
2013 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2014 dumpops, pvlim);
2015 }
8d919b0a 2016 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM
2017 if (!isGV_with_GP(sv))
2018 break;
0eb335df
BF
2019 {
2020 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2021 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2022 generic_pv_escape(tmpsv, GvNAME(sv),
2023 GvNAMELEN(sv),
2024 GvNAMEUTF8(sv)));
2025 }
57def98f 2026 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 2027 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
be108a01 2028 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
57def98f 2029 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c
GS
2030 if (!GvGP(sv))
2031 break;
57def98f
JH
2032 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2033 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2034 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2035 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2036 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2037 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2038 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
008009b0
FC
2040 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
2041 " (%s)\n",
2042 (UV)GvGPFLAGS(sv),
71afaece 2043 "");
57def98f 2044 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 2045 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
3967c732
JD
2046 do_gv_dump (level, file, " EGV", GvEGV(sv));
2047 break;
2048 case SVt_PVIO:
57def98f
JH
2049 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2050 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2051 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2052 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2053 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2054 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2055 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 2056 if (IoTOP_NAME(sv))
cea2e8a9 2057 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC
2058 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2059 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2060 else {
2061 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2062 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC
2063 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2064 maxnest, dumpops, pvlim);
9ba1f565
NC
2065 }
2066 /* Source filters hide things that are not GVs in these three, so let's
2067 be careful out there. */
27533608 2068 if (IoFMT_NAME(sv))
cea2e8a9 2069 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC
2070 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2071 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2072 else {
2073 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2074 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC
2075 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2076 maxnest, dumpops, pvlim);
9ba1f565 2077 }
27533608 2078 if (IoBOTTOM_NAME(sv))
cea2e8a9 2079 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC
2080 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2081 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2082 else {
2083 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2084 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC
2085 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2086 maxnest, dumpops, pvlim);
9ba1f565 2087 }
27533608 2088 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2089 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2090 else
cea2e8a9 2091 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 2092 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732 2093 break;
206ee256 2094 case SVt_REGEXP:
8d919b0a 2095 dumpregexp:
d63e6659 2096 {
8d919b0a 2097 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO
2098
2099#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2100 sv_setpv(d,""); \
e3e400ec 2101 append_flags(d, flags, names); \
ec16d31f
YO
2102 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2103 SvCUR_set(d, SvCUR(d) - 1); \
2104 SvPVX(d)[SvCUR(d)] = '\0'; \
2105 } \
2106} STMT_END
e3e400ec 2107 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
dbc200c5
YO
2108 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2109 (UV)(r->compflags), SvPVX_const(d));
2110
e3e400ec 2111 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
d63e6659 2112 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
dbc200c5
YO
2113 (UV)(r->extflags), SvPVX_const(d));
2114
e3e400ec
YO
2115 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2116 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2117 if (r->engine == &PL_core_reg_engine) {
2118 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2119 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2120 (UV)(r->intflags), SvPVX_const(d));
2121 } else {
2122 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
d63e6659 2123 (UV)(r->intflags));
e3e400ec
YO
2124 }
2125#undef SV_SET_STRINGIFY_REGEXP_FLAGS
d63e6659
DM
2126 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2127 (UV)(r->nparens));
2128 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2129 (UV)(r->lastparen));
2130 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2131 (UV)(r->lastcloseparen));
2132 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2133 (IV)(r->minlen));
2134 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2135 (IV)(r->minlenret));
2136 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2137 (UV)(r->gofs));
2138 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2139 (UV)(r->pre_prefix));
d63e6659
DM
2140 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2141 (IV)(r->sublen));
6502e081
DM
2142 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2143 (IV)(r->suboffset));
2144 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2145 (IV)(r->subcoffset));
d63e6659
DM
2146 if (r->subbeg)
2147 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2148 PTR2UV(r->subbeg),
2149 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2150 else
2151 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
d63e6659
DM
2152 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2153 PTR2UV(r->mother_re));
01ffd0f1
FC
2154 if (nest < maxnest && r->mother_re)
2155 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2156 maxnest, dumpops, pvlim);
d63e6659
DM
2157 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2158 PTR2UV(r->paren_names));
2159 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2160 PTR2UV(r->substrs));
2161 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2162 PTR2UV(r->pprivate));
2163 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2164 PTR2UV(r->offs));
d63c20f2
DM
2165 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2166 PTR2UV(r->qr_anoncv));
db2c6cb3 2167#ifdef PERL_ANY_COW
d63e6659
DM
2168 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2169 PTR2UV(r->saved_copy));
2170#endif
2171 }
206ee256 2172 break;
3967c732 2173 }
5f954473 2174 SvREFCNT_dec_NN(d);
3967c732
JD
2175}
2176
36b1c95c
MH
2177/*
2178=for apidoc sv_dump
2179
2180Dumps the contents of an SV to the C<STDERR> filehandle.
2181
2182For an example of its output, see L<Devel::Peek>.
2183
2184=cut
2185*/
2186
3967c732 2187void
864dbfa3 2188Perl_sv_dump(pTHX_ SV *sv)
3967c732 2189{
7918f24d
NC
2190 PERL_ARGS_ASSERT_SV_DUMP;
2191
d1029faa
JP
2192 if (SvROK(sv))
2193 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2194 else
2195 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2196}
bd16a5f0
IZ
2197
2198int
2199Perl_runops_debug(pTHX)
2200{
2201 if (!PL_op) {
9b387841 2202 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ
2203 return 0;
2204 }
2205
9f3673fb 2206 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2207 do {
75d476e2
SM
2208#ifdef PERL_TRACE_OPS
2209 ++PL_op_exec_cnt[PL_op->op_type];
2210#endif
bd16a5f0 2211 if (PL_debug) {
991bab54
DM
2212 ENTER;
2213 SAVETMPS;
b9ac451d 2214 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0
IZ
2215 PerlIO_printf(Perl_debug_log,
2216 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2217 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2218 PTR2UV(*PL_watchaddr));
d6721266
DM
2219 if (DEBUG_s_TEST_) {
2220 if (DEBUG_v_TEST_) {
2221 PerlIO_printf(Perl_debug_log, "\n");
2222 deb_stack_all();
2223 }
2224 else
2225 debstack();
2226 }
2227
2228
bd16a5f0
IZ
2229 if (DEBUG_t_TEST_) debop(PL_op);
2230 if (DEBUG_P_TEST_) debprof(PL_op);
991bab54
DM
2231 FREETMPS;
2232 LEAVE;
bd16a5f0 2233 }
fe83c362 2234
3f6bd23a 2235 PERL_DTRACE_PROBE_OP(PL_op);
16c91539 2236 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2237 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2238 PERL_ASYNC_CHECK();
bd16a5f0
IZ
2239
2240 TAINT_NOT;
2241 return 0;
2242}
2243
f9b02e42
DM
2244
2245/* print the names of the n lexical vars starting at pad offset off */
2246
f9db5646 2247STATIC void
f9b02e42
DM
2248S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2249{
2250 PADNAME *sv;
2251 CV * const cv = deb_curcv(cxstack_ix);
2252 PADNAMELIST *comppad = NULL;
2253 int i;
2254
2255 if (cv) {
2256 PADLIST * const padlist = CvPADLIST(cv);
2257 comppad = PadlistNAMES(padlist);
2258 }
2259 if (paren)
2260 PerlIO_printf(Perl_debug_log, "(");
2261 for (i = 0; i < n; i++) {
2262 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2263 PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2264 else
2265 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2266 (UV)(off+i));
2267 if (i < n - 1)
2268 PerlIO_printf(Perl_debug_log, ",");
2269 }
2270 if (paren)
2271 PerlIO_printf(Perl_debug_log, ")");
2272}
2273
2274
fedf30e1
DM
2275/* append to the out SV, the name of the lexical at offset off in the CV
2276 * cv */
2277
ec48399d 2278static void
fedf30e1
DM
2279S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2280 bool paren, bool is_scalar)
2281{
2282 PADNAME *sv;
2283 PADNAMELIST *namepad = NULL;
2284 int i;
2285
2286 if (cv) {
2287 PADLIST * const padlist = CvPADLIST(cv);
2288 namepad = PadlistNAMES(padlist);
2289 }
2290
2291 if (paren)
2292 sv_catpvs_nomg(out, "(");
2293 for (i = 0; i < n; i++) {
2294 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2295 {
2296 STRLEN cur = SvCUR(out);
26334c4d
FC
2297 Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2298 UTF8fARG(1, PadnameLEN(sv) - 1,
2299 PadnamePV(sv) + 1));
fedf30e1
DM
2300 if (is_scalar)
2301 SvPVX(out)[cur] = '$';
2302 }
2303 else
2304 Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2305 if (i < n - 1)
2306 sv_catpvs_nomg(out, ",");
2307 }
2308 if (paren)
2309 sv_catpvs_nomg(out, "(");
2310}
2311
2312
ec48399d 2313static void
8bbe2fa8 2314S_append_gv_name(pTHX_ GV *gv, SV *out)
fedf30e1
DM
2315{
2316 SV *sv;
2317 if (!gv) {
2318 sv_catpvs_nomg(out, "<NULLGV>");
2319 return;
2320 }
2321 sv = newSV(0);
2322 gv_fullname4(sv, gv, NULL, FALSE);
ac892e4a 2323 Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv));
fedf30e1
DM
2324 SvREFCNT_dec_NN(sv);
2325}
2326
2327#ifdef USE_ITHREADS
dc3c1c70
DM
2328# define ITEM_SV(item) (comppad ? \
2329 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
fedf30e1
DM
2330#else
2331# define ITEM_SV(item) UNOP_AUX_item_sv(item)
2332#endif
2333
2334
2335/* return a temporary SV containing a stringified representation of
48ee9c0e 2336 * the op_aux field of a MULTIDEREF op, associated with CV cv
fedf30e1
DM
2337 */
2338
2339SV*
48ee9c0e 2340Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
fedf30e1
DM
2341{
2342 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2343 UV actions = items->uv;
2344 SV *sv;
2345 bool last = 0;
2346 bool is_hash = FALSE;
2347 int derefs = 0;
ff94d24c 2348 SV *out = newSVpvn_flags("",0,SVs_TEMP);
fedf30e1 2349#ifdef USE_ITHREADS
dc3c1c70
DM
2350 PAD *comppad;
2351
2352 if (cv) {
2353 PADLIST *padlist = CvPADLIST(cv);
2354 comppad = PadlistARRAY(padlist)[1];
2355 }
2356 else
2357 comppad = NULL;
fedf30e1
DM
2358#endif
2359
48ee9c0e 2360 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
fedf30e1
DM
2361
2362 while (!last) {
2363 switch (actions & MDEREF_ACTION_MASK) {
2364
2365 case MDEREF_reload:
2366 actions = (++items)->uv;
2367 continue;
2b5060ae 2368 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2369
2370 case MDEREF_HV_padhv_helem:
2371 is_hash = TRUE;
2b5060ae 2372 /* FALLTHROUGH */
fedf30e1
DM
2373 case MDEREF_AV_padav_aelem:
2374 derefs = 1;
2375 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2376 goto do_elem;
2b5060ae 2377 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2378
2379 case MDEREF_HV_gvhv_helem:
2380 is_hash = TRUE;
2b5060ae 2381 /* FALLTHROUGH */
fedf30e1
DM
2382 case MDEREF_AV_gvav_aelem:
2383 derefs = 1;
dc3c1c70
DM
2384 items++;
2385 sv = ITEM_SV(items);
8bbe2fa8 2386 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2387 goto do_elem;
2b5060ae 2388 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2389
2390 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2391 is_hash = TRUE;
2b5060ae 2392 /* FALLTHROUGH */
fedf30e1 2393 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
dc3c1c70
DM
2394 items++;
2395 sv = ITEM_SV(items);
8bbe2fa8 2396 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2397 goto do_vivify_rv2xv_elem;
2b5060ae 2398 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2399
2400 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2401 is_hash = TRUE;
2b5060ae 2402 /* FALLTHROUGH */
fedf30e1
DM
2403 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2404 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2405 goto do_vivify_rv2xv_elem;
2b5060ae 2406 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2407
2408 case MDEREF_HV_pop_rv2hv_helem:
2409 case MDEREF_HV_vivify_rv2hv_helem:
2410 is_hash = TRUE;
2b5060ae 2411 /* FALLTHROUGH */
fedf30e1
DM
2412 do_vivify_rv2xv_elem:
2413 case MDEREF_AV_pop_rv2av_aelem:
2414 case MDEREF_AV_vivify_rv2av_aelem:
2415 if (!derefs++)
2416 sv_catpvs_nomg(out, "->");
2417 do_elem:
2418 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2419 sv_catpvs_nomg(out, "->");
2420 last = 1;
2421 break;
2422 }
2423
2424 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2425 switch (actions & MDEREF_INDEX_MASK) {
2426 case MDEREF_INDEX_const:
2427 if (is_hash) {
dc3c1c70
DM
2428 items++;
2429 sv = ITEM_SV(items);
2430 if (!sv)
2431 sv_catpvs_nomg(out, "???");
2432 else {
2433 STRLEN cur;
2434 char *s;
2435 s = SvPV(sv, cur);
2436 pv_pretty(out, s, cur, 30,
2437 NULL, NULL,
2438 (PERL_PV_PRETTY_NOCLEAR
2439 |PERL_PV_PRETTY_QUOTE
2440 |PERL_PV_PRETTY_ELLIPSES));
2441 }
fedf30e1
DM
2442 }
2443 else
2444 Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2445 break;
2446 case MDEREF_INDEX_padsv:
2447 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2448 break;
2449 case MDEREF_INDEX_gvsv:
dc3c1c70
DM
2450 items++;
2451 sv = ITEM_SV(items);
8bbe2fa8 2452 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM
2453 break;
2454 }
2455 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2456
2457 if (actions & MDEREF_FLAG_last)
2458 last = 1;
2459 is_hash = FALSE;
2460
2461 break;
2462
2463 default:
2464 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2465 (int)(actions & MDEREF_ACTION_MASK));
2466 last = 1;
2467 break;
2468
2469 } /* switch */
2470
2471 actions >>= MDEREF_SHIFT;
2472 } /* while */
2473 return out;
2474}
2475
2476
bd16a5f0 2477I32
6867be6d 2478Perl_debop(pTHX_ const OP *o)
bd16a5f0 2479{
7918f24d
NC
2480 PERL_ARGS_ASSERT_DEBOP;
2481
1045810a
IZ
2482 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2483 return 0;
2484
bd16a5f0
IZ
2485 Perl_deb(aTHX_ "%s", OP_NAME(o));
2486 switch (o->op_type) {
2487 case OP_CONST:
996c9baa 2488 case OP_HINTSEVAL:
6cefa69e 2489 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2490 * may not be active here, so check.
6cefa69e 2491 * Looks like only during compiling the pads are illegal.
7367e658 2492 */
6cefa69e
RU
2493#ifdef USE_ITHREADS
2494 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2495#endif
7367e658 2496 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ
2497 break;
2498 case OP_GVSV:
2499 case OP_GV:
8333ca1a 2500 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
b9ac451d 2501 SV * const sv = newSV(0);
bd61b366 2502 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2503 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
5f954473 2504 SvREFCNT_dec_NN(sv);
bd16a5f0 2505 }
8333ca1a
FC
2506 else if (cGVOPo_gv) {
2507 SV * const sv = newSV(0);
2508 assert(SvROK(cGVOPo_gv));
2509 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2510 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
ecf05a58 2511 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
8333ca1a
FC
2512 SvREFCNT_dec_NN(sv);
2513 }
bd16a5f0
IZ
2514 else
2515 PerlIO_printf(Perl_debug_log, "(NULL)");
2516 break;
a7fd8ef6 2517
bd16a5f0
IZ
2518 case OP_PADSV:
2519 case OP_PADAV:
2520 case OP_PADHV:
4fa06845 2521 case OP_ARGELEM:
f9b02e42
DM
2522 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2523 break;
fedf30e1 2524
a7fd8ef6 2525 case OP_PADRANGE:
f9b02e42
DM
2526 S_deb_padvar(aTHX_ o->op_targ,
2527 o->op_private & OPpPADRANGE_COUNTMASK, 1);
bd16a5f0 2528 break;
a7fd8ef6 2529
fedf30e1 2530 case OP_MULTIDEREF:
ac892e4a
DM
2531 PerlIO_printf(Perl_debug_log, "(%"SVf")",
2532 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
fedf30e1
DM
2533 break;
2534
bd16a5f0 2535 default:
091ab601 2536 break;
bd16a5f0
IZ
2537 }
2538 PerlIO_printf(Perl_debug_log, "\n");
2539 return 0;
2540}
2541
2542STATIC CV*
dc6240c9 2543S_deb_curcv(pTHX_ I32 ix)
bd16a5f0 2544{
dc6240c9
DM
2545 PERL_SI *si = PL_curstackinfo;
2546 for (; ix >=0; ix--) {
2547 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2548
2549 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2550 return cx->blk_sub.cv;
2551 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2552 return cx->blk_eval.cv;
2553 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2554 return PL_main_cv;
2555 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2556 && si->si_type == PERLSI_SORT)
2557 {
2558 /* fake sort sub; use CV of caller */
2559 si = si->si_prev;
2560 ix = si->si_cxix + 1;
2561 }
2562 }
2563 return NULL;
bd16a5f0
IZ
2564}
2565
2566void
2567Perl_watch(pTHX_ char **addr)
2568{
7918f24d
NC
2569 PERL_ARGS_ASSERT_WATCH;
2570
bd16a5f0
IZ
2571 PL_watchaddr = addr;
2572 PL_watchok = *addr;
2573 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2574 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2575}
2576
2577STATIC void
e1ec3a88 2578S_debprof(pTHX_ const OP *o)
bd16a5f0 2579{
7918f24d
NC
2580 PERL_ARGS_ASSERT_DEBPROF;
2581
61f9802b 2582 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2583 return;
bd16a5f0 2584 if (!PL_profiledata)
a02a5408 2585 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ
2586 ++PL_profiledata[o->op_type];
2587}
2588
2589void
2590Perl_debprofdump(pTHX)
2591{
2592 unsigned i;
2593 if (!PL_profiledata)
2594 return;
2595 for (i = 0; i < MAXO; i++) {
2596 if (PL_profiledata[i])
2597 PerlIO_printf(Perl_debug_log,
2598 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2599 PL_op_name[i]);
2600 }
2601}
66610fdd 2602
3b721df9 2603
66610fdd 2604/*
14d04a33 2605 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2606 */