This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add Perl_op_class(o) API function
[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,
147e3846 175 "%" UVxf, u);
ab3bbdeb
YO
176 else
177 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
0eb335df 178 ((flags & PERL_PV_ESCAPE_DWIM) && !isuni)
147e3846
KW
179 ? "%cx%02" UVxf
180 : "%cx{%02" UVxf "}", esc, u);
0eb335df 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,
147e3846 210 isuni ? "%cx{%02" UVxf "}" : "%cx%02" UVxf,
0eb335df
BF
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)
147e3846 427 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv));
d5a163ad
DM
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();
147e3846 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))
147e3846 489 Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
cf2093f6 490 else
147e3846 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 622 if (CvISXSUB(GvCV(gv)))
147e3846 623 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
36b1c95c
MH
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))
2e2d70f2
DM
667 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c\n",
668 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
3967c732 669 else
cea2e8a9 670 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
5012eebe
DM
671
672 if (pm->op_type == OP_SPLIT)
147e3846 673 Perl_dump_indent(aTHX_ level, file, "TARGOFF/GV = 0x%" UVxf "\n",
5012eebe
DM
674 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
675 else {
676 if (pm->op_pmreplrootu.op_pmreplroot) {
677 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
678 op_dump(pm->op_pmreplrootu.op_pmreplroot);
679 }
3967c732 680 }
5012eebe 681
68e2671b 682 if (pm->op_code_list) {
867940b8
DM
683 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
684 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
685 do_op_dump(level, file, pm->op_code_list);
686 }
687 else
147e3846 688 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%" UVxf "\n",
867940b8 689 PTR2UV(pm->op_code_list));
68e2671b 690 }
07bc277f 691 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
4199688e 692 SV * const tmpsv = pm_description(pm);
b15aece3 693 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
5f954473 694 SvREFCNT_dec_NN(tmpsv);
3967c732 695 }
3967c732
JD
696}
697
a0c2f4dd
NC
698const struct flag_to_name pmflags_flags_names[] = {
699 {PMf_CONST, ",CONST"},
700 {PMf_KEEP, ",KEEP"},
701 {PMf_GLOBAL, ",GLOBAL"},
702 {PMf_CONTINUE, ",CONTINUE"},
703 {PMf_RETAINT, ",RETAINT"},
704 {PMf_EVAL, ",EVAL"},
705 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
d63c20f2 706 {PMf_HAS_CV, ",HAS_CV"},
2a92a973
DM
707 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
708 {PMf_IS_QR, ",IS_QR"}
a0c2f4dd
NC
709};
710
b9ac451d 711static SV *
4199688e
AL
712S_pm_description(pTHX_ const PMOP *pm)
713{
714 SV * const desc = newSVpvs("");
61f9802b 715 const REGEXP * const regex = PM_GETRE(pm);
4199688e
AL
716 const U32 pmflags = pm->op_pmflags;
717
7918f24d
NC
718 PERL_ARGS_ASSERT_PM_DESCRIPTION;
719
4199688e
AL
720 if (pmflags & PMf_ONCE)
721 sv_catpv(desc, ",ONCE");
c737faaf
YO
722#ifdef USE_ITHREADS
723 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
724 sv_catpv(desc, ":USED");
725#else
726 if (pmflags & PMf_USED)
727 sv_catpv(desc, ":USED");
728#endif
c737faaf 729
68d4833d 730 if (regex) {
284167a5 731 if (RX_ISTAINTED(regex))
68d4833d 732 sv_catpv(desc, ",TAINTED");
07bc277f 733 if (RX_CHECK_SUBSTR(regex)) {
e3e400ec 734 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
68d4833d 735 sv_catpv(desc, ",SCANFIRST");
07bc277f 736 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
68d4833d
AB
737 sv_catpv(desc, ",ALL");
738 }
dbc200c5
YO
739 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
740 sv_catpv(desc, ",SKIPWHITE");
4199688e 741 }
68d4833d 742
a0c2f4dd 743 append_flags(desc, pmflags, pmflags_flags_names);
4199688e
AL
744 return desc;
745}
746
3967c732 747void
864dbfa3 748Perl_pmop_dump(pTHX_ PMOP *pm)
3967c732
JD
749{
750 do_pmop_dump(0, Perl_debug_log, pm);
79072805
LW
751}
752
b6f05621
DM
753/* Return a unique integer to represent the address of op o.
754 * If it already exists in PL_op_sequence, just return it;
755 * otherwise add it.
756 * *** Note that this isn't thread-safe */
294b3b39 757
2814eb74 758STATIC UV
0bd48802 759S_sequence_num(pTHX_ const OP *o)
2814eb74 760{
27da23d5 761 dVAR;
2814eb74
PJ
762 SV *op,
763 **seq;
93524f2b 764 const char *key;
2814eb74 765 STRLEN len;
b6f05621
DM
766 if (!o)
767 return 0;
c0fd1b42 768 op = newSVuv(PTR2UV(o));
b6f05621 769 sv_2mortal(op);
93524f2b 770 key = SvPV_const(op, len);
b6f05621
DM
771 if (!PL_op_sequence)
772 PL_op_sequence = newHV();
773 seq = hv_fetch(PL_op_sequence, key, len, 0);
774 if (seq)
775 return SvUV(*seq);
776 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
777 return PL_op_seq;
2814eb74
PJ
778}
779
f3574cc6
DM
780
781
782
783
a0c2f4dd
NC
784const struct flag_to_name op_flags_names[] = {
785 {OPf_KIDS, ",KIDS"},
786 {OPf_PARENS, ",PARENS"},
a0c2f4dd
NC
787 {OPf_REF, ",REF"},
788 {OPf_MOD, ",MOD"},
65cccc5e 789 {OPf_STACKED, ",STACKED"},
a0c2f4dd
NC
790 {OPf_SPECIAL, ",SPECIAL"}
791};
792
75a6ad4a 793
79072805 794void
6867be6d 795Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
79072805 796{
2814eb74 797 UV seq;
e15d5972
AL
798 const OPCODE optype = o->op_type;
799
7918f24d
NC
800 PERL_ARGS_ASSERT_DO_OP_DUMP;
801
cea2e8a9 802 Perl_dump_indent(aTHX_ level, file, "{\n");
3967c732 803 level++;
0bd48802 804 seq = sequence_num(o);
2814eb74 805 if (seq)
147e3846 806 PerlIO_printf(file, "%-4" UVuf, seq);
93a17b20 807 else
b6f05621 808 PerlIO_printf(file, "????");
c8db6e60
JH
809 PerlIO_printf(file,
810 "%*sTYPE = %s ===> ",
53e06cf0 811 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
2814eb74 812 if (o->op_next)
b6f05621 813 PerlIO_printf(file,
147e3846 814 o->op_type == OP_NULL ? "(%" UVuf ")\n" : "%" UVuf "\n",
666ea192 815 sequence_num(o->op_next));
79072805 816 else
e75ab6ad 817 PerlIO_printf(file, "NULL\n");
11343788 818 if (o->op_targ) {
e15d5972 819 if (optype == OP_NULL) {
cea2e8a9 820 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
ae7d165c 821 }
8990e307 822 else
894356b3 823 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
8990e307 824 }
748a9306 825#ifdef DUMPADDR
147e3846
KW
826 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%" UVxf " => 0x%" UVxf "\n",
827 (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 912 if (enum_label == -1)
147e3846 913 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
95268469
DM
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, ",");
147e3846 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
147e3846
KW
938 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%" UVxf ")\n",
939 (UV)oppriv);
760f8c06
DM
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++)
147e3846 973 Perl_dump_indent(aTHX_ level+1, file, "%" UVuf " => 0x%" UVxf "\n",
fedf30e1 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))
147e3846 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)
147e3846 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)
147e3846 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)
147e3846 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)
147e3846 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)
147e3846 1063 Perl_dump_indent(aTHX_ level, file, "REFCNT = %" UVuf "\n", (UV)o->op_targ);
7934575e 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 1135 Perl_dump_indent(aTHX_ level, file,
147e3846 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
147e3846
KW
1145 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1146 UVxf "\n", PTR2UV(v));
3967c732
JD
1147 }
1148 else
cea2e8a9 1149 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
8d063cd8 1150
3967c732 1151 if (mg->mg_private)
cea2e8a9 1152 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
3967c732 1153
14befaf4
DM
1154 {
1155 int n;
c445ea15 1156 const char *name = NULL;
27da23d5 1157 for (n = 0; magic_names[n].name; n++) {
14befaf4
DM
1158 if (mg->mg_type == magic_names[n].type) {
1159 name = magic_names[n].name;
1160 break;
1161 }
1162 }
1163 if (name)
1164 Perl_dump_indent(aTHX_ level, file,
1165 " MG_TYPE = PERL_MAGIC_%s\n", name);
1166 else
1167 Perl_dump_indent(aTHX_ level, file,
1168 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1169 }
3967c732
JD
1170
1171 if (mg->mg_flags) {
cea2e8a9 1172 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
cb50f42d
YST
1173 if (mg->mg_type == PERL_MAGIC_envelem &&
1174 mg->mg_flags & MGf_TAINTEDDIR)
cea2e8a9 1175 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
4c02285a
FR
1176 if (mg->mg_type == PERL_MAGIC_regex_global &&
1177 mg->mg_flags & MGf_MINMATCH)
1178 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
3967c732 1179 if (mg->mg_flags & MGf_REFCOUNTED)
cea2e8a9 1180 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1181 if (mg->mg_flags & MGf_GSKIP)
cea2e8a9 1182 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
4c02285a
FR
1183 if (mg->mg_flags & MGf_COPY)
1184 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1185 if (mg->mg_flags & MGf_DUP)
1186 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1187 if (mg->mg_flags & MGf_LOCAL)
1188 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
25fdce4a
FC
1189 if (mg->mg_type == PERL_MAGIC_regex_global &&
1190 mg->mg_flags & MGf_BYTES)
1191 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
3967c732
JD
1192 }
1193 if (mg->mg_obj) {
147e3846 1194 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
28d8d7f4
YO
1195 PTR2UV(mg->mg_obj));
1196 if (mg->mg_type == PERL_MAGIC_qr) {
07bc277f 1197 REGEXP* const re = (REGEXP *)mg->mg_obj;
61f9802b 1198 SV * const dsv = sv_newmortal();
866c78d1 1199 const char * const s
4c02285a 1200 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
28d8d7f4 1201 60, NULL, NULL,
95b611b0 1202 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
3c8556c3 1203 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
28d8d7f4 1204 );
6483fb35 1205 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
147e3846 1206 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
07bc277f 1207 (IV)RX_REFCNT(re));
28d8d7f4
YO
1208 }
1209 if (mg->mg_flags & MGf_REFCOUNTED)
3967c732
JD
1210 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1211 }
1212 if (mg->mg_len)
894356b3 1213 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1214 if (mg->mg_ptr) {
147e3846 1215 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
3967c732 1216 if (mg->mg_len >= 0) {
7e8c5dac 1217 if (mg->mg_type != PERL_MAGIC_utf8) {
17605be7 1218 SV * const sv = newSVpvs("");
7e8c5dac 1219 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
17605be7 1220 SvREFCNT_dec_NN(sv);
7e8c5dac 1221 }
3967c732
JD
1222 }
1223 else if (mg->mg_len == HEf_SVKEY) {
1224 PerlIO_puts(file, " => HEf_SVKEY\n");
ad64d0ec
NC
1225 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1226 maxnest, dumpops, pvlim); /* MG is already +1 */
3967c732
JD
1227 continue;
1228 }
866f9d6c 1229 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
3967c732 1230 else
866f9d6c
FC
1231 PerlIO_puts(
1232 file,
1233 " ???? - " __FILE__
1234 " does not know how to handle this MG_LEN"
1235 );
38d7fd8b 1236 (void)PerlIO_putc(file, '\n');
3967c732 1237 }
7e8c5dac 1238 if (mg->mg_type == PERL_MAGIC_utf8) {
61f9802b 1239 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7e8c5dac
HS
1240 if (cache) {
1241 IV i;
1242 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1243 Perl_dump_indent(aTHX_ level, file,
147e3846 1244 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
7e8c5dac
HS
1245 i,
1246 (UV)cache[i * 2],
1247 (UV)cache[i * 2 + 1]);
1248 }
1249 }
378cc40b 1250 }
3967c732
JD
1251}
1252
1253void
6867be6d 1254Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1255{
b9ac451d 1256 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732
JD
1257}
1258
1259void
e1ec3a88 1260Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1261{
bfcb3514 1262 const char *hvname;
7918f24d
NC
1263
1264 PERL_ARGS_ASSERT_DO_HV_DUMP;
1265
147e3846 1266 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
bfcb3514 1267 if (sv && (hvname = HvNAME_get(sv)))
d7d51f4b
YO
1268 {
1269 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1270 name which quite legally could contain insane things like tabs, newlines, nulls or
1271 other scary crap - this should produce sane results - except maybe for unicode package
1272 names - but we will wait for someone to file a bug on that - demerphq */
0eb335df
BF
1273 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1274 PerlIO_printf(file, "\t\"%s\"\n",
1275 generic_pv_escape( tmpsv, hvname,
1276 HvNAMELEN(sv), HvNAMEUTF8(sv)));
d7d51f4b 1277 }
79072805 1278 else
38d7fd8b 1279 (void)PerlIO_putc(file, '\n');
3967c732
JD
1280}
1281
1282void
e1ec3a88 1283Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1284{
7918f24d
NC
1285 PERL_ARGS_ASSERT_DO_GV_DUMP;
1286
147e3846 1287 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
0eb335df
BF
1288 if (sv && GvNAME(sv)) {
1289 SV * const tmpsv = newSVpvs("");
1290 PerlIO_printf(file, "\t\"%s\"\n",
1291 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1292 }
c90c0ff4 1293 else
38d7fd8b 1294 (void)PerlIO_putc(file, '\n');
3967c732
JD
1295}
1296
1297void
e1ec3a88 1298Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1299{
7918f24d
NC
1300 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1301
147e3846 1302 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
3967c732 1303 if (sv && GvNAME(sv)) {
0eb335df 1304 SV *tmp = newSVpvs_flags("", SVs_TEMP);
bfcb3514 1305 const char *hvname;
0eb335df
BF
1306 HV * const stash = GvSTASH(sv);
1307 PerlIO_printf(file, "\t");
1308 /* TODO might have an extra \" here */
1309 if (stash && (hvname = HvNAME_get(stash))) {
1310 PerlIO_printf(file, "\"%s\" :: \"",
1311 generic_pv_escape(tmp, hvname,
1312 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1313 }
1314 PerlIO_printf(file, "%s\"\n",
1315 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
8d063cd8 1316 }
3967c732 1317 else
38d7fd8b 1318 (void)PerlIO_putc(file, '\n');
3967c732
JD
1319}
1320
a0c2f4dd
NC
1321const struct flag_to_name first_sv_flags_names[] = {
1322 {SVs_TEMP, "TEMP,"},
1323 {SVs_OBJECT, "OBJECT,"},
1324 {SVs_GMG, "GMG,"},
1325 {SVs_SMG, "SMG,"},
1326 {SVs_RMG, "RMG,"},
1327 {SVf_IOK, "IOK,"},
1328 {SVf_NOK, "NOK,"},
1329 {SVf_POK, "POK,"}
1330};
1331
1332const struct flag_to_name second_sv_flags_names[] = {
1333 {SVf_OOK, "OOK,"},
1334 {SVf_FAKE, "FAKE,"},
1335 {SVf_READONLY, "READONLY,"},
fd01b4b7 1336 {SVf_PROTECT, "PROTECT,"},
a0c2f4dd 1337 {SVf_BREAK, "BREAK,"},
a0c2f4dd
NC
1338 {SVp_IOK, "pIOK,"},
1339 {SVp_NOK, "pNOK,"},
1340 {SVp_POK, "pPOK,"}
1341};
1342
ae1f06a1
NC
1343const struct flag_to_name cv_flags_names[] = {
1344 {CVf_ANON, "ANON,"},
1345 {CVf_UNIQUE, "UNIQUE,"},
1346 {CVf_CLONE, "CLONE,"},
1347 {CVf_CLONED, "CLONED,"},
1348 {CVf_CONST, "CONST,"},
1349 {CVf_NODEBUG, "NODEBUG,"},
1350 {CVf_LVALUE, "LVALUE,"},
1351 {CVf_METHOD, "METHOD,"},
cfc1e951 1352 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1353 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1354 {CVf_DYNFILE, "DYNFILE,"},
8fa6a409 1355 {CVf_AUTOLOAD, "AUTOLOAD,"},
e4555ecf 1356 {CVf_HASEVAL, "HASEVAL,"},
bfbc3ad9 1357 {CVf_SLABBED, "SLABBED,"},
bf9a4d2d 1358 {CVf_NAMED, "NAMED,"},
82487b59 1359 {CVf_LEXICAL, "LEXICAL,"},
31d45e0c 1360 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC
1361};
1362
1363const struct flag_to_name hv_flags_names[] = {
1364 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1365 {SVphv_LAZYDEL, "LAZYDEL,"},
1366 {SVphv_HASKFLAGS, "HASKFLAGS,"},
45eaf8af 1367 {SVf_AMAGIC, "OVERLOAD,"},
ae1f06a1
NC
1368 {SVphv_CLONEABLE, "CLONEABLE,"}
1369};
1370
1371const struct flag_to_name gp_flags_names[] = {
1372 {GVf_INTRO, "INTRO,"},
1373 {GVf_MULTI, "MULTI,"},
1374 {GVf_ASSUMECV, "ASSUMECV,"},
ae1f06a1
NC
1375};
1376
1377const struct flag_to_name gp_flags_imported_names[] = {
1378 {GVf_IMPORTED_SV, " SV"},
1379 {GVf_IMPORTED_AV, " AV"},
1380 {GVf_IMPORTED_HV, " HV"},
1381 {GVf_IMPORTED_CV, " CV"},
1382};
1383
0d331aaf
YO
1384/* NOTE: this structure is mostly duplicative of one generated by
1385 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1386 * the two. - Yves */
e3e400ec 1387const struct flag_to_name regexp_extflags_names[] = {
d63e6659
DM
1388 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1389 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1390 {RXf_PMf_FOLD, "PMf_FOLD,"},
1391 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
334afb3e 1392 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
d63e6659 1393 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
41d7c59e 1394 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
8e1490ee 1395 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
dbc200c5 1396 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
d63e6659 1397 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
d63e6659
DM
1398 {RXf_CHECK_ALL, "CHECK_ALL,"},
1399 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1400 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1401 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1402 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
dbc200c5 1403 {RXf_SPLIT, "SPLIT,"},
d63e6659
DM
1404 {RXf_COPY_DONE, "COPY_DONE,"},
1405 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1406 {RXf_TAINTED, "TAINTED,"},
1407 {RXf_START_ONLY, "START_ONLY,"},
dbc200c5 1408 {RXf_SKIPWHITE, "SKIPWHITE,"},
d63e6659
DM
1409 {RXf_WHITE, "WHITE,"},
1410 {RXf_NULL, "NULL,"},
1411};
1412
0d331aaf
YO
1413/* NOTE: this structure is mostly duplicative of one generated by
1414 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1415 * the two. - Yves */
e3e400ec
YO
1416const struct flag_to_name regexp_core_intflags_names[] = {
1417 {PREGf_SKIP, "SKIP,"},
0d331aaf
YO
1418 {PREGf_IMPLICIT, "IMPLICIT,"},
1419 {PREGf_NAUGHTY, "NAUGHTY,"},
e3e400ec
YO
1420 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1421 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
0d331aaf 1422 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
e3e400ec 1423 {PREGf_NOSCAN, "NOSCAN,"},
58430ea8
YO
1424 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1425 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
8e1490ee
YO
1426 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1427 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1428 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
e3e400ec
YO
1429};
1430
c24d0595
DM
1431/* Perl_do_sv_dump():
1432 *
1433 * level: amount to indent the output
1434 * sv: the object to dump
1435 * nest: the current level of recursion
1436 * maxnest: the maximum allowed level of recursion
1437 * dumpops: if true, also dump the ops associated with a CV
1438 * pvlim: limit on the length of any strings that are output
1439 * */
1440
3967c732 1441void
864dbfa3 1442Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1443{
cea89e20 1444 SV *d;
e1ec3a88 1445 const char *s;
3967c732
JD
1446 U32 flags;
1447 U32 type;
1448
7918f24d
NC
1449 PERL_ARGS_ASSERT_DO_SV_DUMP;
1450
3967c732 1451 if (!sv) {
cea2e8a9 1452 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1453 return;
378cc40b 1454 }
2ef28da1 1455
3967c732
JD
1456 flags = SvFLAGS(sv);
1457 type = SvTYPE(sv);
79072805 1458
e0bbf362
DM
1459 /* process general SV flags */
1460
cea89e20 1461 d = Perl_newSVpvf(aTHX_
147e3846 1462 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
56431972 1463 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS
1464 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1465 (int)(PL_dumpindent*level), "");
8d063cd8 1466
0f94cb1f 1467 if ((flags & SVs_PADSTALE))
9a214eec 1468 sv_catpv(d, "PADSTALE,");
0f94cb1f 1469 if ((flags & SVs_PADTMP))
9a214eec 1470 sv_catpv(d, "PADTMP,");
a0c2f4dd 1471 append_flags(d, flags, first_sv_flags_names);
810b8aa5
GS
1472 if (flags & SVf_ROK) {
1473 sv_catpv(d, "ROK,");
1474 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1475 }
45eaf8af 1476 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
a0c2f4dd 1477 append_flags(d, flags, second_sv_flags_names);
7db6405c
FC
1478 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1479 && type != SVt_PVAV) {
1ccdb730
NC
1480 if (SvPCS_IMPORTED(sv))
1481 sv_catpv(d, "PCS_IMPORTED,");
1482 else
9660f481 1483 sv_catpv(d, "SCREAM,");
1ccdb730 1484 }
3967c732 1485
e0bbf362
DM
1486 /* process type-specific SV flags */
1487
3967c732
JD
1488 switch (type) {
1489 case SVt_PVCV:
1490 case SVt_PVFM:
ae1f06a1 1491 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD
1492 break;
1493 case SVt_PVHV:
ae1f06a1 1494 append_flags(d, flags, hv_flags_names);
3967c732 1495 break;
926fc7b6
DM
1496 case SVt_PVGV:
1497 case SVt_PVLV:
1498 if (isGV_with_GP(sv)) {
ae1f06a1 1499 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1500 }
926fc7b6 1501 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD
1502 sv_catpv(d, "IMPORT");
1503 if (GvIMPORTED(sv) == GVf_IMPORTED)
1504 sv_catpv(d, "ALL,");
1505 else {
1506 sv_catpv(d, "(");
ae1f06a1 1507 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
3967c732
JD
1508 sv_catpv(d, " ),");
1509 }
1510 }
924ba076 1511 /* FALLTHROUGH */
a5c7cb08 1512 case SVt_PVMG:
25da4f38 1513 default:
69c678eb 1514 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1515 break;
a5c7cb08 1516
11ca45c0
NC
1517 case SVt_PVAV:
1518 break;
3967c732 1519 }
86f0d186
NC
1520 /* SVphv_SHAREKEYS is also 0x20000000 */
1521 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1522 sv_catpv(d, "UTF8");
3967c732 1523
b162af07
SP
1524 if (*(SvEND(d) - 1) == ',') {
1525 SvCUR_set(d, SvCUR(d) - 1);
1526 SvPVX(d)[SvCUR(d)] = '\0';
1527 }
3967c732 1528 sv_catpv(d, ")");
b15aece3 1529 s = SvPVX_const(d);
3967c732 1530
e0bbf362
DM
1531 /* dump initial SV details */
1532
fd0854ff 1533#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1534 Perl_dump_indent(aTHX_ level, file,
147e3846 1535 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
fd0854ff
DM
1536 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1537 sv->sv_debug_line,
1538 sv->sv_debug_inpad ? "for" : "by",
1539 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1540 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM
1541 sv->sv_debug_serial
1542 );
fd0854ff 1543#endif
cea2e8a9 1544 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM
1545
1546 /* Dump SV type */
1547
5357ca29
NC
1548 if (type < SVt_LAST) {
1549 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1550
1551 if (type == SVt_NULL) {
5f954473 1552 SvREFCNT_dec_NN(d);
5357ca29
NC
1553 return;
1554 }
1555 } else {
147e3846 1556 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
5f954473 1557 SvREFCNT_dec_NN(d);
3967c732
JD
1558 return;
1559 }
e0bbf362
DM
1560
1561 /* Dump general SV fields */
1562
27bd069f 1563 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC
1564 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1565 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1566 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1567 if (SvIsUV(sv)
765f542d 1568 )
147e3846 1569 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
cf2093f6 1570 else
147e3846 1571 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
38d7fd8b 1572 (void)PerlIO_putc(file, '\n');
3967c732 1573 }
e0bbf362 1574
0f94cb1f 1575 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1576 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1577 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1578 || type == SVt_NV) {
67d796ae 1579 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
88cb8500 1580 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
67d796ae 1581 RESTORE_LC_NUMERIC_UNDERLYING();
3967c732 1582 }
e0bbf362 1583
3967c732 1584 if (SvROK(sv)) {
147e3846
KW
1585 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1586 PTR2UV(SvRV(sv)));
3967c732
JD
1587 if (nest < maxnest)
1588 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1589 }
e0bbf362 1590
cea89e20 1591 if (type < SVt_PV) {
5f954473 1592 SvREFCNT_dec_NN(d);
3967c732 1593 return;
cea89e20 1594 }
e0bbf362 1595
5a3c7349
FC
1596 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1597 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
8d919b0a
FC
1598 const bool re = isREGEXP(sv);
1599 const char * const ptr =
1600 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1601 if (ptr) {
69240efd 1602 STRLEN delta;
7a4bba22 1603 if (SvOOK(sv)) {
69240efd 1604 SvOOK_offset(sv, delta);
147e3846 1605 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
5186cc12 1606 (UV) delta);
69240efd
NC
1607 } else {
1608 delta = 0;
7a4bba22 1609 }
147e3846
KW
1610 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1611 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 }
147e3846 1632 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
8d919b0a 1633 if (!re)
147e3846 1634 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
8d919b0a 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)) {
147e3846
KW
1653 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1654 (IV)BmUSEFUL(sv));
c13a5c80 1655 }
3967c732 1656 }
e0bbf362
DM
1657
1658 /* Dump type-specific SV fields */
1659
3967c732 1660 switch (type) {
3967c732 1661 case SVt_PVAV:
147e3846
KW
1662 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1663 PTR2UV(AvARRAY(sv)));
3967c732 1664 if (AvARRAY(sv) != AvALLOC(sv)) {
147e3846
KW
1665 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1666 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1667 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1668 PTR2UV(AvALLOC(sv)));
3967c732
JD
1669 }
1670 else
38d7fd8b 1671 (void)PerlIO_putc(file, '\n');
147e3846
KW
1672 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1673 (IV)AvFILLp(sv));
1674 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1675 (IV)AvMAX(sv));
ed0faf2e 1676 SvPVCLEAR(d);
11ca45c0
NC
1677 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1678 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP
1679 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1680 SvCUR(d) ? SvPVX_const(d) + 1 : "");
476fafda 1681 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
c70927a6 1682 SSize_t count;
476fafda
DM
1683 SV **svp = AvARRAY(MUTABLE_AV(sv));
1684 for (count = 0;
1685 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1686 count++, svp++)
1687 {
1688 SV* const elt = *svp;
147e3846
KW
1689 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1690 (IV)count);
476fafda 1691 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
3967c732
JD
1692 }
1693 }
1694 break;
5d27ee4a
DD
1695 case SVt_PVHV: {
1696 U32 usedkeys;
0c22a733
DM
1697 if (SvOOK(sv)) {
1698 struct xpvhv_aux *const aux = HvAUX(sv);
147e3846 1699 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
0c22a733
DM
1700 (UV)aux->xhv_aux_flags);
1701 }
147e3846 1702 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
5d27ee4a
DD
1703 usedkeys = HvUSEDKEYS(sv);
1704 if (HvARRAY(sv) && usedkeys) {
3967c732
JD
1705 /* Show distribution of HEs in the ARRAY */
1706 int freq[200];
c3caa5c3 1707#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
3967c732
JD
1708 int i;
1709 int max = 0;
5d27ee4a 1710 U32 pow2 = 2, keys = usedkeys;
65202027 1711 NV theoret, sum = 0;
3967c732
JD
1712
1713 PerlIO_printf(file, " (");
1714 Zero(freq, FREQ_MAX + 1, int);
eb160463 1715 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL
1716 HE* h;
1717 int count = 0;
3967c732
JD
1718 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1719 count++;
1720 if (count > FREQ_MAX)
1721 count = FREQ_MAX;
1722 freq[count]++;
1723 if (max < count)
1724 max = count;
1725 }
1726 for (i = 0; i <= max; i++) {
1727 if (freq[i]) {
1728 PerlIO_printf(file, "%d%s:%d", i,
1729 (i == FREQ_MAX) ? "+" : "",
1730 freq[i]);
1731 if (i != max)
1732 PerlIO_printf(file, ", ");
1733 }
1734 }
38d7fd8b 1735 (void)PerlIO_putc(file, ')');
b8fa94d8
MG
1736 /* The "quality" of a hash is defined as the total number of
1737 comparisons needed to access every element once, relative
1738 to the expected number needed for a random hash.
1739
1740 The total number of comparisons is equal to the sum of
e76cd0fa
AMS
1741 the squares of the number of entries in each bucket.
1742 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG
1743 value is
1744 n + n(n-1)/2k
1745 */
1746
3967c732
JD
1747 for (i = max; i > 0; i--) { /* Precision: count down. */
1748 sum += freq[i] * i * i;
1749 }
155aba94 1750 while ((keys = keys >> 1))
3967c732 1751 pow2 = pow2 << 1;
5d27ee4a 1752 theoret = usedkeys;
b8fa94d8 1753 theoret += theoret * (theoret-1)/pow2;
38d7fd8b 1754 (void)PerlIO_putc(file, '\n');
147e3846
KW
1755 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
1756 NVff "%%", theoret/sum*100);
3967c732 1757 }
38d7fd8b 1758 (void)PerlIO_putc(file, '\n');
147e3846
KW
1759 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
1760 (IV)usedkeys);
9faf471a
NC
1761 {
1762 STRLEN count = 0;
1763 HE **ents = HvARRAY(sv);
1764
1765 if (ents) {
1766 HE *const *const last = ents + HvMAX(sv);
1767 count = last + 1 - ents;
1768
1769 do {
1770 if (!*ents)
1771 --count;
1772 } while (++ents <= last);
1773 }
1774
147e3846 1775 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
8bf4c401 1776 (UV)count);
9faf471a 1777 }
147e3846
KW
1778 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1779 (IV)HvMAX(sv));
e1a7ec8d 1780 if (SvOOK(sv)) {
147e3846
KW
1781 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
1782 (IV)HvRITER_get(sv));
1783 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
1784 PTR2UV(HvEITER_get(sv)));
6a5b4183 1785#ifdef PERL_HASH_RANDOMIZE_KEYS
147e3846
KW
1786 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
1787 (UV)HvRAND_get(sv));
e1a7ec8d 1788 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
147e3846
KW
1789 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
1790 (UV)HvLASTRAND_get(sv));
e1a7ec8d 1791 }
6a5b4183 1792#endif
38d7fd8b 1793 (void)PerlIO_putc(file, '\n');
e1a7ec8d 1794 }
8d2f4536 1795 {
b9ac451d 1796 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536 1797 if (mg && mg->mg_obj) {
147e3846 1798 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
8d2f4536
NC
1799 }
1800 }
bfcb3514 1801 {
b9ac451d 1802 const char * const hvname = HvNAME_get(sv);
0eb335df
BF
1803 if (hvname) {
1804 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1805 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1806 generic_pv_escape( tmpsv, hvname,
1807 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1808 }
bfcb3514 1809 }
86f55936 1810 if (SvOOK(sv)) {
ad64d0ec 1811 AV * const backrefs
85fbaab2 1812 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 1813 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC
1814 if (HvAUX(sv)->xhv_name_count)
1815 Perl_dump_indent(aTHX_
147e3846 1816 level, file, " NAMECOUNT = %" IVdf "\n",
7afc2217 1817 (IV)HvAUX(sv)->xhv_name_count
67e04715 1818 );
15d9236d 1819 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC
1820 const I32 count = HvAUX(sv)->xhv_name_count;
1821 if (count) {
1822 SV * const names = newSVpvs_flags("", SVs_TEMP);
1823 /* The starting point is the first element if count is
1824 positive and the second element if count is negative. */
1825 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1826 + (count < 0 ? 1 : 0);
1827 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1828 + (count < 0 ? -count : count);
1829 while (hekp < endp) {
8e5993c4 1830 if (*hekp) {
0eb335df
BF
1831 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1832 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1833 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
ec3405c8
NC
1834 } else {
1835 /* This should never happen. */
1836 sv_catpvs(names, ", (null)");
67e04715 1837 }
ec3405c8
NC
1838 ++hekp;
1839 }
67e04715
FC
1840 Perl_dump_indent(aTHX_
1841 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1842 );
1843 }
0eb335df
BF
1844 else {
1845 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1846 const char *const hvename = HvENAME_get(sv);
67e04715 1847 Perl_dump_indent(aTHX_
0eb335df
BF
1848 level, file, " ENAME = \"%s\"\n",
1849 generic_pv_escape(tmp, hvename,
1850 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1851 }
67e04715 1852 }
86f55936 1853 if (backrefs) {
147e3846 1854 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
86f55936 1855 PTR2UV(backrefs));
ad64d0ec 1856 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC
1857 dumpops, pvlim);
1858 }
7d88e6c4 1859 if (meta) {
0eb335df 1860 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
147e3846
KW
1861 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
1862 UVxf ")\n",
0eb335df
BF
1863 generic_pv_escape( tmpsv, meta->mro_which->name,
1864 meta->mro_which->length,
1865 (meta->mro_which->kflags & HVhek_UTF8)),
7d88e6c4 1866 PTR2UV(meta->mro_which));
147e3846
KW
1867 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
1868 UVxf "\n",
7d88e6c4 1869 (UV)meta->cache_gen);
147e3846 1870 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
7d88e6c4
NC
1871 (UV)meta->pkg_gen);
1872 if (meta->mro_linear_all) {
147e3846
KW
1873 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
1874 UVxf "\n",
7d88e6c4
NC
1875 PTR2UV(meta->mro_linear_all));
1876 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1877 dumpops, pvlim);
1878 }
1879 if (meta->mro_linear_current) {
147e3846
KW
1880 Perl_dump_indent(aTHX_ level, file,
1881 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
7d88e6c4
NC
1882 PTR2UV(meta->mro_linear_current));
1883 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1884 dumpops, pvlim);
1885 }
1886 if (meta->mro_nextmethod) {
147e3846
KW
1887 Perl_dump_indent(aTHX_ level, file,
1888 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
7d88e6c4
NC
1889 PTR2UV(meta->mro_nextmethod));
1890 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1891 dumpops, pvlim);
1892 }
1893 if (meta->isa) {
147e3846 1894 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
7d88e6c4
NC
1895 PTR2UV(meta->isa));
1896 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1897 dumpops, pvlim);
1898 }
1899 }
86f55936 1900 }
b5698553 1901 if (nest < maxnest) {
cbab3169 1902 HV * const hv = MUTABLE_HV(sv);
b5698553
TH
1903 STRLEN i;
1904 HE *he;
cbab3169 1905
b5698553
TH
1906 if (HvARRAY(hv)) {
1907 int count = maxnest - nest;
1908 for (i=0; i <= HvMAX(hv); i++) {
1909 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1910 U32 hash;
1911 SV * keysv;
1912 const char * keypv;
1913 SV * elt;
7dc86639 1914 STRLEN len;
b5698553
TH
1915
1916 if (count-- <= 0) goto DONEHV;
1917
1918 hash = HeHASH(he);
1919 keysv = hv_iterkeysv(he);
1920 keypv = SvPV_const(keysv, len);
1921 elt = HeVAL(he);
cbab3169 1922
7dc86639
YO
1923 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1924 if (SvUTF8(keysv))
1925 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH
1926 if (HvEITER_get(hv) == he)
1927 PerlIO_printf(file, "[CURRENT] ");
147e3846 1928 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
7dc86639
YO
1929 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1930 }
b5698553
TH
1931 }
1932 DONEHV:;
1933 }
3967c732
JD
1934 }
1935 break;
5d27ee4a 1936 } /* case SVt_PVHV */
e0bbf362 1937
3967c732 1938 case SVt_PVCV:
8fa6a409 1939 if (CvAUTOLOAD(sv)) {
0eb335df
BF
1940 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1941 STRLEN len;
8fa6a409 1942 const char *const name = SvPV_const(sv, len);
0eb335df
BF
1943 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1944 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
8fa6a409
FC
1945 }
1946 if (SvPOK(sv)) {
0eb335df
BF
1947 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1948 const char *const proto = CvPROTO(sv);
1949 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1950 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1951 SvUTF8(sv)));
cbf82dd0 1952 }
924ba076 1953 /* FALLTHROUGH */
3967c732
JD
1954 case SVt_PVFM:
1955 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC
1956 if (!CvISXSUB(sv)) {
1957 if (CvSTART(sv)) {
27604593
DM
1958 if (CvSLABBED(sv))
1959 Perl_dump_indent(aTHX_ level, file,
147e3846 1960 " SLAB = 0x%" UVxf "\n",
27604593
DM
1961 PTR2UV(CvSTART(sv)));
1962 else
1963 Perl_dump_indent(aTHX_ level, file,
147e3846 1964 " START = 0x%" UVxf " ===> %" IVdf "\n",
d04ba589
NC
1965 PTR2UV(CvSTART(sv)),
1966 (IV)sequence_num(CvSTART(sv)));
1967 }
147e3846 1968 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
d04ba589
NC
1969 PTR2UV(CvROOT(sv)));
1970 if (CvROOT(sv) && dumpops) {
1971 do_op_dump(level+1, file, CvROOT(sv));
1972 }
1973 } else {
126f53f3 1974 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 1975
147e3846 1976 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
b1886099
NC
1977
1978 if (constant) {
147e3846 1979 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
b1886099
NC
1980 " (CONST SV)\n",
1981 PTR2UV(CvXSUBANY(sv).any_ptr));
1982 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1983 pvlim);
1984 } else {
147e3846 1985 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
b1886099
NC
1986 (IV)CvXSUBANY(sv).any_i32);
1987 }
1988 }
3610c89f
FC
1989 if (CvNAMED(sv))
1990 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1991 HEK_KEY(CvNAME_HEK((CV *)sv)));
1992 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1993 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
147e3846
KW
1994 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
1995 IVdf "\n", (IV)CvDEPTH(sv));
1996 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
1997 (UV)CvFLAGS(sv));
1998 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
eacbb379 1999 if (!CvISXSUB(sv)) {
147e3846 2000 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
eacbb379
DD
2001 if (nest < maxnest) {
2002 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2003 }
3967c732 2004 }
eacbb379 2005 else
db6e00bd 2006 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
3967c732 2007 {
b9ac451d 2008 const CV * const outside = CvOUTSIDE(sv);
147e3846 2009 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
57def98f 2010 PTR2UV(outside),
cf2093f6
JH
2011 (!outside ? "null"
2012 : CvANON(outside) ? "ANON"
2013 : (outside == PL_main_cv) ? "MAIN"
2014 : CvUNIQUE(outside) ? "UNIQUE"
b24fda9d
BF
2015 : CvGV(outside) ?
2016 generic_pv_escape(
2017 newSVpvs_flags("", SVs_TEMP),
2018 GvNAME(CvGV(outside)),
2019 GvNAMELEN(CvGV(outside)),
2020 GvNAMEUTF8(CvGV(outside)))
2021 : "UNDEFINED"));
3967c732 2022 }
704b97aa
FC
2023 if (CvOUTSIDE(sv)
2024 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
ad64d0ec 2025 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2026 break;
e0bbf362 2027
926fc7b6
DM
2028 case SVt_PVGV:
2029 case SVt_PVLV:
b9ac451d
AL
2030 if (type == SVt_PVLV) {
2031 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
147e3846
KW
2032 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2033 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2034 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2035 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
305b8651 2036 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
b9ac451d
AL
2037 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2038 dumpops, pvlim);
2039 }
8d919b0a 2040 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM
2041 if (!isGV_with_GP(sv))
2042 break;
0eb335df
BF
2043 {
2044 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2045 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2046 generic_pv_escape(tmpsv, GvNAME(sv),
2047 GvNAMELEN(sv),
2048 GvNAMEUTF8(sv)));
2049 }
147e3846 2050 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
3967c732 2051 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
147e3846
KW
2052 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2053 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
f472eb5c
GS
2054 if (!GvGP(sv))
2055 break;
147e3846
KW
2056 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2057 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2058 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2059 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2060 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2061 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2062 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2063 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2064 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
008009b0
FC
2065 " (%s)\n",
2066 (UV)GvGPFLAGS(sv),
71afaece 2067 "");
147e3846 2068 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
b195d487 2069 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
3967c732
JD
2070 do_gv_dump (level, file, " EGV", GvEGV(sv));
2071 break;
2072 case SVt_PVIO:
147e3846
KW
2073 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2074 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2075 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2076 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2077 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2078 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2079 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
27533608 2080 if (IoTOP_NAME(sv))
cea2e8a9 2081 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC
2082 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2083 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2084 else {
147e3846 2085 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
9ba1f565 2086 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC
2087 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2088 maxnest, dumpops, pvlim);
9ba1f565
NC
2089 }
2090 /* Source filters hide things that are not GVs in these three, so let's
2091 be careful out there. */
27533608 2092 if (IoFMT_NAME(sv))
cea2e8a9 2093 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC
2094 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2095 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2096 else {
147e3846 2097 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
9ba1f565 2098 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC
2099 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2100 maxnest, dumpops, pvlim);
9ba1f565 2101 }
27533608 2102 if (IoBOTTOM_NAME(sv))
cea2e8a9 2103 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC
2104 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2105 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2106 else {
147e3846 2107 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
9ba1f565 2108 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC
2109 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2110 maxnest, dumpops, pvlim);
9ba1f565 2111 }
27533608 2112 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2113 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2114 else
cea2e8a9 2115 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
147e3846 2116 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
3967c732 2117 break;
206ee256 2118 case SVt_REGEXP:
8d919b0a 2119 dumpregexp:
d63e6659 2120 {
8d919b0a 2121 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO
2122
2123#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2124 sv_setpv(d,""); \
e3e400ec 2125 append_flags(d, flags, names); \
ec16d31f
YO
2126 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2127 SvCUR_set(d, SvCUR(d) - 1); \
2128 SvPVX(d)[SvCUR(d)] = '\0'; \
2129 } \
2130} STMT_END
e3e400ec 2131 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
147e3846 2132 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO
2133 (UV)(r->compflags), SvPVX_const(d));
2134
e3e400ec 2135 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
147e3846 2136 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO
2137 (UV)(r->extflags), SvPVX_const(d));
2138
147e3846 2139 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
e3e400ec
YO
2140 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2141 if (r->engine == &PL_core_reg_engine) {
2142 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
147e3846 2143 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
e3e400ec
YO
2144 (UV)(r->intflags), SvPVX_const(d));
2145 } else {
147e3846 2146 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
d63e6659 2147 (UV)(r->intflags));
e3e400ec
YO
2148 }
2149#undef SV_SET_STRINGIFY_REGEXP_FLAGS
147e3846 2150 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
d63e6659 2151 (UV)(r->nparens));
147e3846 2152 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
d63e6659 2153 (UV)(r->lastparen));
147e3846 2154 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
d63e6659 2155 (UV)(r->lastcloseparen));
147e3846 2156 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
d63e6659 2157 (IV)(r->minlen));
147e3846 2158 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
d63e6659 2159 (IV)(r->minlenret));
147e3846 2160 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
d63e6659 2161 (UV)(r->gofs));
147e3846 2162 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
d63e6659 2163 (UV)(r->pre_prefix));
147e3846 2164 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
d63e6659 2165 (IV)(r->sublen));
147e3846 2166 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
6502e081 2167 (IV)(r->suboffset));
147e3846 2168 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
6502e081 2169 (IV)(r->subcoffset));
d63e6659 2170 if (r->subbeg)
147e3846 2171 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
d63e6659
DM
2172 PTR2UV(r->subbeg),
2173 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2174 else
2175 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
147e3846 2176 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
d63e6659 2177 PTR2UV(r->mother_re));
01ffd0f1
FC
2178 if (nest < maxnest && r->mother_re)
2179 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2180 maxnest, dumpops, pvlim);
147e3846 2181 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
d63e6659 2182 PTR2UV(r->paren_names));
147e3846 2183 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
d63e6659 2184 PTR2UV(r->substrs));
147e3846 2185 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
d63e6659 2186 PTR2UV(r->pprivate));
147e3846 2187 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
d63e6659 2188 PTR2UV(r->offs));
147e3846 2189 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
d63c20f2 2190 PTR2UV(r->qr_anoncv));
db2c6cb3 2191#ifdef PERL_ANY_COW
147e3846 2192 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
d63e6659
DM
2193 PTR2UV(r->saved_copy));
2194#endif
2195 }
206ee256 2196 break;
3967c732 2197 }
5f954473 2198 SvREFCNT_dec_NN(d);
3967c732
JD
2199}
2200
36b1c95c
MH
2201/*
2202=for apidoc sv_dump
2203
2204Dumps the contents of an SV to the C<STDERR> filehandle.
2205
2206For an example of its output, see L<Devel::Peek>.
2207
2208=cut
2209*/
2210
3967c732 2211void
864dbfa3 2212Perl_sv_dump(pTHX_ SV *sv)
3967c732 2213{
7918f24d
NC
2214 PERL_ARGS_ASSERT_SV_DUMP;
2215
d1029faa
JP
2216 if (SvROK(sv))
2217 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2218 else
2219 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2220}
bd16a5f0
IZ
2221
2222int
2223Perl_runops_debug(pTHX)
2224{
2225 if (!PL_op) {
9b387841 2226 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ
2227 return 0;
2228 }
2229
9f3673fb 2230 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2231 do {
75d476e2
SM
2232#ifdef PERL_TRACE_OPS
2233 ++PL_op_exec_cnt[PL_op->op_type];
2234#endif
bd16a5f0 2235 if (PL_debug) {
991bab54
DM
2236 ENTER;
2237 SAVETMPS;
b9ac451d 2238 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0 2239 PerlIO_printf(Perl_debug_log,
147e3846 2240 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
bd16a5f0
IZ
2241 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2242 PTR2UV(*PL_watchaddr));
d6721266
DM
2243 if (DEBUG_s_TEST_) {
2244 if (DEBUG_v_TEST_) {
2245 PerlIO_printf(Perl_debug_log, "\n");
2246 deb_stack_all();
2247 }
2248 else
2249 debstack();
2250 }
2251
2252
bd16a5f0
IZ
2253 if (DEBUG_t_TEST_) debop(PL_op);
2254 if (DEBUG_P_TEST_) debprof(PL_op);
991bab54
DM
2255 FREETMPS;
2256 LEAVE;
bd16a5f0 2257 }
fe83c362 2258
3f6bd23a 2259 PERL_DTRACE_PROBE_OP(PL_op);
16c91539 2260 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2261 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2262 PERL_ASYNC_CHECK();
bd16a5f0
IZ
2263
2264 TAINT_NOT;
2265 return 0;
2266}
2267
f9b02e42
DM
2268
2269/* print the names of the n lexical vars starting at pad offset off */
2270
f9db5646 2271STATIC void
f9b02e42
DM
2272S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2273{
2274 PADNAME *sv;
2275 CV * const cv = deb_curcv(cxstack_ix);
2276 PADNAMELIST *comppad = NULL;
2277 int i;
2278
2279 if (cv) {
2280 PADLIST * const padlist = CvPADLIST(cv);
2281 comppad = PadlistNAMES(padlist);
2282 }
2283 if (paren)
2284 PerlIO_printf(Perl_debug_log, "(");
2285 for (i = 0; i < n; i++) {
2286 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
147e3846 2287 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
f9b02e42 2288 else
147e3846 2289 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
f9b02e42
DM
2290 (UV)(off+i));
2291 if (i < n - 1)
2292 PerlIO_printf(Perl_debug_log, ",");
2293 }
2294 if (paren)
2295 PerlIO_printf(Perl_debug_log, ")");
2296}
2297
2298
fedf30e1
DM
2299/* append to the out SV, the name of the lexical at offset off in the CV
2300 * cv */
2301
ec48399d 2302static void
fedf30e1
DM
2303S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2304 bool paren, bool is_scalar)
2305{
2306 PADNAME *sv;
2307 PADNAMELIST *namepad = NULL;
2308 int i;
2309
2310 if (cv) {
2311 PADLIST * const padlist = CvPADLIST(cv);
2312 namepad = PadlistNAMES(padlist);
2313 }
2314
2315 if (paren)
2316 sv_catpvs_nomg(out, "(");
2317 for (i = 0; i < n; i++) {
2318 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2319 {
2320 STRLEN cur = SvCUR(out);
147e3846 2321 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
26334c4d
FC
2322 UTF8fARG(1, PadnameLEN(sv) - 1,
2323 PadnamePV(sv) + 1));
fedf30e1
DM
2324 if (is_scalar)
2325 SvPVX(out)[cur] = '$';
2326 }
2327 else
147e3846 2328 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
fedf30e1
DM
2329 if (i < n - 1)
2330 sv_catpvs_nomg(out, ",");
2331 }
2332 if (paren)
2333 sv_catpvs_nomg(out, "(");
2334}
2335
2336
ec48399d 2337static void
8bbe2fa8 2338S_append_gv_name(pTHX_ GV *gv, SV *out)
fedf30e1
DM
2339{
2340 SV *sv;
2341 if (!gv) {
2342 sv_catpvs_nomg(out, "<NULLGV>");
2343 return;
2344 }
2345 sv = newSV(0);
2346 gv_fullname4(sv, gv, NULL, FALSE);
147e3846 2347 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
fedf30e1
DM
2348 SvREFCNT_dec_NN(sv);
2349}
2350
2351#ifdef USE_ITHREADS
dc3c1c70
DM
2352# define ITEM_SV(item) (comppad ? \
2353 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
fedf30e1
DM
2354#else
2355# define ITEM_SV(item) UNOP_AUX_item_sv(item)
2356#endif
2357
2358
2359/* return a temporary SV containing a stringified representation of
48ee9c0e 2360 * the op_aux field of a MULTIDEREF op, associated with CV cv
fedf30e1
DM
2361 */
2362
2363SV*
48ee9c0e 2364Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
fedf30e1
DM
2365{
2366 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2367 UV actions = items->uv;
2368 SV *sv;
2369 bool last = 0;
2370 bool is_hash = FALSE;
2371 int derefs = 0;
ff94d24c 2372 SV *out = newSVpvn_flags("",0,SVs_TEMP);
fedf30e1 2373#ifdef USE_ITHREADS
dc3c1c70
DM
2374 PAD *comppad;
2375
2376 if (cv) {
2377 PADLIST *padlist = CvPADLIST(cv);
2378 comppad = PadlistARRAY(padlist)[1];
2379 }
2380 else
2381 comppad = NULL;
fedf30e1
DM
2382#endif
2383
48ee9c0e 2384 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
fedf30e1
DM
2385
2386 while (!last) {
2387 switch (actions & MDEREF_ACTION_MASK) {
2388
2389 case MDEREF_reload:
2390 actions = (++items)->uv;
2391 continue;
2b5060ae 2392 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2393
2394 case MDEREF_HV_padhv_helem:
2395 is_hash = TRUE;
2b5060ae 2396 /* FALLTHROUGH */
fedf30e1
DM
2397 case MDEREF_AV_padav_aelem:
2398 derefs = 1;
2399 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2400 goto do_elem;
2b5060ae 2401 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2402
2403 case MDEREF_HV_gvhv_helem:
2404 is_hash = TRUE;
2b5060ae 2405 /* FALLTHROUGH */
fedf30e1
DM
2406 case MDEREF_AV_gvav_aelem:
2407 derefs = 1;
dc3c1c70
DM
2408 items++;
2409 sv = ITEM_SV(items);
8bbe2fa8 2410 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2411 goto do_elem;
2b5060ae 2412 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2413
2414 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2415 is_hash = TRUE;
2b5060ae 2416 /* FALLTHROUGH */
fedf30e1 2417 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
dc3c1c70
DM
2418 items++;
2419 sv = ITEM_SV(items);
8bbe2fa8 2420 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2421 goto do_vivify_rv2xv_elem;
2b5060ae 2422 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2423
2424 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2425 is_hash = TRUE;
2b5060ae 2426 /* FALLTHROUGH */
fedf30e1
DM
2427 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2428 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2429 goto do_vivify_rv2xv_elem;
2b5060ae 2430 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2431
2432 case MDEREF_HV_pop_rv2hv_helem:
2433 case MDEREF_HV_vivify_rv2hv_helem:
2434 is_hash = TRUE;
2b5060ae 2435 /* FALLTHROUGH */
fedf30e1
DM
2436 do_vivify_rv2xv_elem:
2437 case MDEREF_AV_pop_rv2av_aelem:
2438 case MDEREF_AV_vivify_rv2av_aelem:
2439 if (!derefs++)
2440 sv_catpvs_nomg(out, "->");
2441 do_elem:
2442 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2443 sv_catpvs_nomg(out, "->");
2444 last = 1;
2445 break;
2446 }
2447
2448 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2449 switch (actions & MDEREF_INDEX_MASK) {
2450 case MDEREF_INDEX_const:
2451 if (is_hash) {
dc3c1c70
DM
2452 items++;
2453 sv = ITEM_SV(items);
2454 if (!sv)
2455 sv_catpvs_nomg(out, "???");
2456 else {
2457 STRLEN cur;
2458 char *s;
2459 s = SvPV(sv, cur);
2460 pv_pretty(out, s, cur, 30,
2461 NULL, NULL,
2462 (PERL_PV_PRETTY_NOCLEAR
2463 |PERL_PV_PRETTY_QUOTE
2464 |PERL_PV_PRETTY_ELLIPSES));
2465 }
fedf30e1
DM
2466 }
2467 else
147e3846 2468 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
fedf30e1
DM
2469 break;
2470 case MDEREF_INDEX_padsv:
2471 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2472 break;
2473 case MDEREF_INDEX_gvsv:
dc3c1c70
DM
2474 items++;
2475 sv = ITEM_SV(items);
8bbe2fa8 2476 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM
2477 break;
2478 }
2479 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2480
2481 if (actions & MDEREF_FLAG_last)
2482 last = 1;
2483 is_hash = FALSE;
2484
2485 break;
2486
2487 default:
2488 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2489 (int)(actions & MDEREF_ACTION_MASK));
2490 last = 1;
2491 break;
2492
2493 } /* switch */
2494
2495 actions >>= MDEREF_SHIFT;
2496 } /* while */
2497 return out;
2498}
2499
2500
bd16a5f0 2501I32
6867be6d 2502Perl_debop(pTHX_ const OP *o)
bd16a5f0 2503{
7918f24d
NC
2504 PERL_ARGS_ASSERT_DEBOP;
2505
1045810a
IZ
2506 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2507 return 0;
2508
bd16a5f0
IZ
2509 Perl_deb(aTHX_ "%s", OP_NAME(o));
2510 switch (o->op_type) {
2511 case OP_CONST:
996c9baa 2512 case OP_HINTSEVAL:
6cefa69e 2513 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2514 * may not be active here, so check.
6cefa69e 2515 * Looks like only during compiling the pads are illegal.
7367e658 2516 */
6cefa69e
RU
2517#ifdef USE_ITHREADS
2518 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2519#endif
7367e658 2520 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ
2521 break;
2522 case OP_GVSV:
2523 case OP_GV:
8333ca1a 2524 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
b9ac451d 2525 SV * const sv = newSV(0);
bd61b366 2526 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2527 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
5f954473 2528 SvREFCNT_dec_NN(sv);
bd16a5f0 2529 }
8333ca1a
FC
2530 else if (cGVOPo_gv) {
2531 SV * const sv = newSV(0);
2532 assert(SvROK(cGVOPo_gv));
2533 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2534 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
ecf05a58 2535 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
8333ca1a
FC
2536 SvREFCNT_dec_NN(sv);
2537 }
bd16a5f0
IZ
2538 else
2539 PerlIO_printf(Perl_debug_log, "(NULL)");
2540 break;
a7fd8ef6 2541
bd16a5f0
IZ
2542 case OP_PADSV:
2543 case OP_PADAV:
2544 case OP_PADHV:
4fa06845 2545 case OP_ARGELEM:
f9b02e42
DM
2546 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2547 break;
fedf30e1 2548
a7fd8ef6 2549 case OP_PADRANGE:
f9b02e42
DM
2550 S_deb_padvar(aTHX_ o->op_targ,
2551 o->op_private & OPpPADRANGE_COUNTMASK, 1);
bd16a5f0 2552 break;
a7fd8ef6 2553
fedf30e1 2554 case OP_MULTIDEREF:
147e3846 2555 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
ac892e4a 2556 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
fedf30e1
DM
2557 break;
2558
bd16a5f0 2559 default:
091ab601 2560 break;
bd16a5f0
IZ
2561 }
2562 PerlIO_printf(Perl_debug_log, "\n");
2563 return 0;
2564}
2565
1e85b658
DM
2566
2567/*
2568=for apidoc op_class
2569
2570Given an op, determine what type of struct it has been allocated as.
2571Returns one of the OPclass enums, such as OPclass_LISTOP.
2572
2573=cut
2574*/
2575
2576
2577OPclass
2578Perl_op_class(pTHX_ const OP *o)
2579{
2580 bool custom = 0;
2581
2582 if (!o)
2583 return OPclass_NULL;
2584
2585 if (o->op_type == 0) {
2586 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2587 return OPclass_COP;
2588 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2589 }
2590
2591 if (o->op_type == OP_SASSIGN)
2592 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2593
2594 if (o->op_type == OP_AELEMFAST) {
2595#ifdef USE_ITHREADS
2596 return OPclass_PADOP;
2597#else
2598 return OPclass_SVOP;
2599#endif
2600 }
2601
2602#ifdef USE_ITHREADS
2603 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2604 o->op_type == OP_RCATLINE)
2605 return OPclass_PADOP;
2606#endif
2607
2608 if (o->op_type == OP_CUSTOM)
2609 custom = 1;
2610
2611 switch (OP_CLASS(o)) {
2612 case OA_BASEOP:
2613 return OPclass_BASEOP;
2614
2615 case OA_UNOP:
2616 return OPclass_UNOP;
2617
2618 case OA_BINOP:
2619 return OPclass_BINOP;
2620
2621 case OA_LOGOP:
2622 return OPclass_LOGOP;
2623
2624 case OA_LISTOP:
2625 return OPclass_LISTOP;
2626
2627 case OA_PMOP:
2628 return OPclass_PMOP;
2629
2630 case OA_SVOP:
2631 return OPclass_SVOP;
2632
2633 case OA_PADOP:
2634 return OPclass_PADOP;
2635
2636 case OA_PVOP_OR_SVOP:
2637 /*
2638 * Character translations (tr///) are usually a PVOP, keeping a
2639 * pointer to a table of shorts used to look up translations.
2640 * Under utf8, however, a simple table isn't practical; instead,
2641 * the OP is an SVOP (or, under threads, a PADOP),
2642 * and the SV is a reference to a swash
2643 * (i.e., an RV pointing to an HV).
2644 */
2645 return (!custom &&
2646 (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2647 )
2648#if defined(USE_ITHREADS)
2649 ? OPclass_PADOP : OPclass_PVOP;
2650#else
2651 ? OPclass_SVOP : OPclass_PVOP;
2652#endif
2653
2654 case OA_LOOP:
2655 return OPclass_LOOP;
2656
2657 case OA_COP:
2658 return OPclass_COP;
2659
2660 case OA_BASEOP_OR_UNOP:
2661 /*
2662 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2663 * whether parens were seen. perly.y uses OPf_SPECIAL to
2664 * signal whether a BASEOP had empty parens or none.
2665 * Some other UNOPs are created later, though, so the best
2666 * test is OPf_KIDS, which is set in newUNOP.
2667 */
2668 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2669
2670 case OA_FILESTATOP:
2671 /*
2672 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2673 * the OPf_REF flag to distinguish between OP types instead of the
2674 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2675 * return OPclass_UNOP so that walkoptree can find our children. If
2676 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2677 * (no argument to the operator) it's an OP; with OPf_REF set it's
2678 * an SVOP (and op_sv is the GV for the filehandle argument).
2679 */
2680 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2681#ifdef USE_ITHREADS
2682 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2683#else
2684 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
2685#endif
2686 case OA_LOOPEXOP:
2687 /*
2688 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
2689 * label was omitted (in which case it's a BASEOP) or else a term was
2690 * seen. In this last case, all except goto are definitely PVOP but
2691 * goto is either a PVOP (with an ordinary constant label), an UNOP
2692 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
2693 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
2694 * get set.
2695 */
2696 if (o->op_flags & OPf_STACKED)
2697 return OPclass_UNOP;
2698 else if (o->op_flags & OPf_SPECIAL)
2699 return OPclass_BASEOP;
2700 else
2701 return OPclass_PVOP;
2702 case OA_METHOP:
2703 return OPclass_METHOP;
2704 case OA_UNOP_AUX:
2705 return OPclass_UNOP_AUX;
2706 }
2707 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
2708 OP_NAME(o));
2709 return OPclass_BASEOP;
2710}
2711
2712
2713
bd16a5f0 2714STATIC CV*
dc6240c9 2715S_deb_curcv(pTHX_ I32 ix)
bd16a5f0 2716{
dc6240c9
DM
2717 PERL_SI *si = PL_curstackinfo;
2718 for (; ix >=0; ix--) {
2719 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2720
2721 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2722 return cx->blk_sub.cv;
2723 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2724 return cx->blk_eval.cv;
2725 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2726 return PL_main_cv;
2727 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2728 && si->si_type == PERLSI_SORT)
2729 {
2730 /* fake sort sub; use CV of caller */
2731 si = si->si_prev;
2732 ix = si->si_cxix + 1;
2733 }
2734 }
2735 return NULL;
bd16a5f0
IZ
2736}
2737
2738void
2739Perl_watch(pTHX_ char **addr)
2740{
7918f24d
NC
2741 PERL_ARGS_ASSERT_WATCH;
2742
bd16a5f0
IZ
2743 PL_watchaddr = addr;
2744 PL_watchok = *addr;
147e3846 2745 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
bd16a5f0
IZ
2746 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2747}
2748
2749STATIC void
e1ec3a88 2750S_debprof(pTHX_ const OP *o)
bd16a5f0 2751{
7918f24d
NC
2752 PERL_ARGS_ASSERT_DEBPROF;
2753
61f9802b 2754 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2755 return;
bd16a5f0 2756 if (!PL_profiledata)
a02a5408 2757 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ
2758 ++PL_profiledata[o->op_type];
2759}
2760
2761void
2762Perl_debprofdump(pTHX)
2763{
2764 unsigned i;
2765 if (!PL_profiledata)
2766 return;
2767 for (i = 0; i < MAXO; i++) {
2768 if (PL_profiledata[i])
2769 PerlIO_printf(Perl_debug_log,
2770 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2771 PL_op_name[i]);
2772 }
2773}
66610fdd 2774
3b721df9 2775
66610fdd 2776/*
14d04a33 2777 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2778 */