This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add PL_curstackinfo->si_stack_hwm
[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:
6f3289f0 208 if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
0eb335df 209 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
147e3846 210 isuni ? "%cx{%02" UVxf "}" : "%cx%02" UVxf,
0eb335df 211 esc, u);
6f3289f0
DM
212 }
213 else if ((pv+readsize < end) && isDIGIT((U8)*(pv+readsize)))
214 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75 215 "%c%03o", esc, c);
6f3289f0
DM
216 else
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
cd6e4874
DM
526
527/* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar
528 * for each indent level as appropriate.
529 *
530 * bar contains bits indicating which indent columns should have a
531 * vertical bar displayed. Bit 0 is the RH-most column. If there are more
532 * levels than bits in bar, then the first few indents are displayed
533 * without a bar.
534 *
535 * The start of a new op is signalled by passing a value for level which
536 * has been negated and offset by 1 (so that level 0 is passed as -1 and
537 * can thus be distinguished from -0); in this case, emit a suitably
538 * indented blank line, then on the next line, display the op's sequence
539 * number, and make the final indent an '+----'.
540 *
541 * e.g.
542 *
543 * | FOO # level = 1, bar = 0b1
544 * | | # level =-2-1, bar = 0b11
545 * 1234 | +---BAR
546 * | BAZ # level = 2, bar = 0b10
547 */
548
549static void
550S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
551 const char* pat, ...)
552{
553 va_list args;
554 I32 i;
555 bool newop = (level < 0);
556
557 va_start(args, pat);
558
559 /* start displaying a new op? */
560 if (newop) {
561 UV seq = sequence_num(o);
562
563 level = -level - 1;
564
565 /* output preceding blank line */
566 PerlIO_puts(file, " ");
567 for (i = level-1; i >= 0; i--)
568 PerlIO_puts(file, i == 0 || (bar & (1 << i)) ? "| " : " ");
569 PerlIO_puts(file, "\n");
570
571 /* output sequence number */
572 if (seq)
573 PerlIO_printf(file, "%-4" UVuf " ", seq);
574 else
575 PerlIO_puts(file, "???? ");
576
577 }
578 else
579 PerlIO_printf(file, " ");
580
581 for (i = level-1; i >= 0; i--)
582 PerlIO_puts(file,
583 (i == 0 && newop) ? "+--"
584 : (bar & (1 << i)) ? "| "
585 : " ");
586 PerlIO_vprintf(file, pat, args);
587 va_end(args);
588}
589
590
591/* display a link field (e.g. op_next) in the format
592 * ====> sequence_number [opname 0x123456]
593 */
594
595static void
596S_opdump_link(pTHX_ const OP *o, PerlIO *file)
597{
598 PerlIO_puts(file, " ===> ");
599 if (o)
600 PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n",
601 sequence_num(o), OP_NAME(o), PTR2UV(o));
602 else
603 PerlIO_puts(file, "[0x0]\n");
604}
605
36b1c95c
MH
606/*
607=for apidoc dump_all
608
609Dumps the entire optree of the current program starting at C<PL_main_root> to
72d33970
FC
610C<STDERR>. Also dumps the optrees for all visible subroutines in
611C<PL_defstash>.
36b1c95c
MH
612
613=cut
614*/
615
616void
617Perl_dump_all(pTHX)
618{
619 dump_all_perl(FALSE);
620}
621
622void
623Perl_dump_all_perl(pTHX_ bool justperl)
624{
36b1c95c
MH
625 PerlIO_setlinebuf(Perl_debug_log);
626 if (PL_main_root)
627 op_dump(PL_main_root);
628 dump_packsubs_perl(PL_defstash, justperl);
629}
630
631/*
632=for apidoc dump_packsubs
633
634Dumps the optrees for all visible subroutines in C<stash>.
635
636=cut
637*/
638
639void
640Perl_dump_packsubs(pTHX_ const HV *stash)
641{
642 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
643 dump_packsubs_perl(stash, FALSE);
644}
645
646void
647Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
648{
36b1c95c
MH
649 I32 i;
650
651 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
652
653 if (!HvARRAY(stash))
654 return;
655 for (i = 0; i <= (I32) HvMAX(stash); i++) {
656 const HE *entry;
657 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
66103581
DM
658 GV * gv = (GV *)HeVAL(entry);
659 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
660 /* unfake a fake GV */
661 (void)CvGV(SvRV(gv));
36b1c95c
MH
662 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
663 continue;
664 if (GvCVu(gv))
665 dump_sub_perl(gv, justperl);
666 if (GvFORM(gv))
667 dump_form(gv);
668 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
669 const HV * const hv = GvHV(gv);
670 if (hv && (hv != PL_defstash))
671 dump_packsubs_perl(hv, justperl); /* nested package */
672 }
673 }
674 }
675}
676
677void
678Perl_dump_sub(pTHX_ const GV *gv)
679{
680 PERL_ARGS_ASSERT_DUMP_SUB;
681 dump_sub_perl(gv, FALSE);
682}
683
684void
685Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
686{
27b4ba23 687 CV *cv;
36b1c95c
MH
688
689 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
690
27b4ba23
Z
691 cv = isGV_with_GP(gv) ? GvCV(gv) :
692 (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
693 if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
36b1c95c
MH
694 return;
695
27b4ba23
Z
696 if (isGV_with_GP(gv)) {
697 SV * const namesv = newSVpvs_flags("", SVs_TEMP);
698 SV *escsv = newSVpvs_flags("", SVs_TEMP);
699 const char *namepv;
700 STRLEN namelen;
701 gv_fullname3(namesv, gv, NULL);
702 namepv = SvPV_const(namesv, namelen);
703 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
704 generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
705 } else {
706 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
707 }
708 if (CvISXSUB(cv))
147e3846 709 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
27b4ba23
Z
710 PTR2UV(CvXSUB(cv)),
711 (int)CvXSUBANY(cv).any_i32);
712 else if (CvROOT(cv))
713 op_dump(CvROOT(cv));
36b1c95c
MH
714 else
715 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
716}
717
718void
719Perl_dump_form(pTHX_ const GV *gv)
720{
721 SV * const sv = sv_newmortal();
722
723 PERL_ARGS_ASSERT_DUMP_FORM;
724
725 gv_fullname3(sv, gv, NULL);
726 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
727 if (CvROOT(GvFORM(gv)))
728 op_dump(CvROOT(GvFORM(gv)));
729 else
730 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
731}
732
733void
734Perl_dump_eval(pTHX)
735{
36b1c95c
MH
736 op_dump(PL_eval_root);
737}
738
cd6e4874 739
e18c4116
DM
740/* returns a temp SV displaying the name of a GV. Handles the case where
741 * a GV is in fact a ref to a CV */
742
743static SV *
744S_gv_display(pTHX_ GV *gv)
745{
abd07ec0 746 SV * const name = newSVpvs_flags("", SVs_TEMP);
e18c4116
DM
747 if (gv) {
748 SV * const raw = newSVpvs_flags("", SVs_TEMP);
749 STRLEN len;
750 const char * rawpv;
751
752 if (isGV_with_GP(gv))
753 gv_fullname3(raw, gv, NULL);
754 else {
755 assert(SvROK(gv));
756 assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
757 Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
758 SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
759 }
760 rawpv = SvPV_const(raw, len);
761 generic_pv_escape(name, rawpv, len, SvUTF8(raw));
762 }
763 else
764 sv_catpvs(name, "(NULL)");
765
766 return name;
767}
768
769
770
cd6e4874
DM
771/* forward decl */
772static void
773S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
774
775
776static void
777S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm)
3967c732 778{
cd6e4874 779 UV kidbar;
7918f24d 780
8efda520 781 if (!pm)
3967c732 782 return;
cd6e4874
DM
783
784 kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1;
785
f0d3f5ac
DM
786 if (PM_GETRE(pm)) {
787 char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/';
cd6e4874 788 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n",
2e2d70f2 789 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
f0d3f5ac 790 }
3967c732 791 else
cd6e4874
DM
792 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n");
793
794 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
795 SV * const tmpsv = pm_description(pm);
796 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n",
797 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
798 SvREFCNT_dec_NN(tmpsv);
799 }
5012eebe
DM
800
801 if (pm->op_type == OP_SPLIT)
cd6e4874
DM
802 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
803 "TARGOFF/GV = 0x%" UVxf "\n",
804 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
5012eebe
DM
805 else {
806 if (pm->op_pmreplrootu.op_pmreplroot) {
cd6e4874
DM
807 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n");
808 S_do_op_dump_bar(aTHX_ level + 2,
809 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))),
810 file, pm->op_pmreplrootu.op_pmreplroot);
5012eebe 811 }
3967c732 812 }
5012eebe 813
68e2671b 814 if (pm->op_code_list) {
867940b8 815 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
cd6e4874
DM
816 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n");
817 S_do_op_dump_bar(aTHX_ level + 2,
818 (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))),
819 file, pm->op_code_list);
867940b8
DM
820 }
821 else
cd6e4874
DM
822 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file,
823 "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list));
3967c732 824 }
3967c732
JD
825}
826
cd6e4874
DM
827
828void
829Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
830{
831 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
832 S_do_pmop_dump_bar(aTHX_ level, 0, file, pm);
833}
834
835
a0c2f4dd
NC
836const struct flag_to_name pmflags_flags_names[] = {
837 {PMf_CONST, ",CONST"},
838 {PMf_KEEP, ",KEEP"},
839 {PMf_GLOBAL, ",GLOBAL"},
840 {PMf_CONTINUE, ",CONTINUE"},
841 {PMf_RETAINT, ",RETAINT"},
842 {PMf_EVAL, ",EVAL"},
843 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
d63c20f2 844 {PMf_HAS_CV, ",HAS_CV"},
2a92a973
DM
845 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
846 {PMf_IS_QR, ",IS_QR"}
a0c2f4dd
NC
847};
848
b9ac451d 849static SV *
4199688e
AL
850S_pm_description(pTHX_ const PMOP *pm)
851{
852 SV * const desc = newSVpvs("");
61f9802b 853 const REGEXP * const regex = PM_GETRE(pm);
4199688e
AL
854 const U32 pmflags = pm->op_pmflags;
855
7918f24d
NC
856 PERL_ARGS_ASSERT_PM_DESCRIPTION;
857
4199688e
AL
858 if (pmflags & PMf_ONCE)
859 sv_catpv(desc, ",ONCE");
c737faaf
YO
860#ifdef USE_ITHREADS
861 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
862 sv_catpv(desc, ":USED");
863#else
864 if (pmflags & PMf_USED)
865 sv_catpv(desc, ":USED");
866#endif
c737faaf 867
68d4833d 868 if (regex) {
284167a5 869 if (RX_ISTAINTED(regex))
68d4833d 870 sv_catpv(desc, ",TAINTED");
07bc277f 871 if (RX_CHECK_SUBSTR(regex)) {
e3e400ec 872 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
68d4833d 873 sv_catpv(desc, ",SCANFIRST");
07bc277f 874 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
68d4833d
AB
875 sv_catpv(desc, ",ALL");
876 }
dbc200c5
YO
877 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
878 sv_catpv(desc, ",SKIPWHITE");
4199688e 879 }
68d4833d 880
a0c2f4dd 881 append_flags(desc, pmflags, pmflags_flags_names);
4199688e
AL
882 return desc;
883}
884
3967c732 885void
864dbfa3 886Perl_pmop_dump(pTHX_ PMOP *pm)
3967c732
JD
887{
888 do_pmop_dump(0, Perl_debug_log, pm);
79072805
LW
889}
890
b6f05621
DM
891/* Return a unique integer to represent the address of op o.
892 * If it already exists in PL_op_sequence, just return it;
893 * otherwise add it.
894 * *** Note that this isn't thread-safe */
294b3b39 895
2814eb74 896STATIC UV
0bd48802 897S_sequence_num(pTHX_ const OP *o)
2814eb74 898{
27da23d5 899 dVAR;
2814eb74
PJ
900 SV *op,
901 **seq;
93524f2b 902 const char *key;
2814eb74 903 STRLEN len;
b6f05621
DM
904 if (!o)
905 return 0;
c0fd1b42 906 op = newSVuv(PTR2UV(o));
b6f05621 907 sv_2mortal(op);
93524f2b 908 key = SvPV_const(op, len);
b6f05621
DM
909 if (!PL_op_sequence)
910 PL_op_sequence = newHV();
911 seq = hv_fetch(PL_op_sequence, key, len, 0);
912 if (seq)
913 return SvUV(*seq);
914 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
915 return PL_op_seq;
2814eb74
PJ
916}
917
f3574cc6
DM
918
919
920
921
a0c2f4dd
NC
922const struct flag_to_name op_flags_names[] = {
923 {OPf_KIDS, ",KIDS"},
924 {OPf_PARENS, ",PARENS"},
a0c2f4dd
NC
925 {OPf_REF, ",REF"},
926 {OPf_MOD, ",MOD"},
65cccc5e 927 {OPf_STACKED, ",STACKED"},
a0c2f4dd
NC
928 {OPf_SPECIAL, ",SPECIAL"}
929};
930
75a6ad4a 931
cd6e4874 932/* indexed by enum OPclass */
521aa9ac 933const char * const op_class_names[] = {
cd6e4874
DM
934 "NULL",
935 "OP",
936 "UNOP",
937 "BINOP",
938 "LOGOP",
939 "LISTOP",
940 "PMOP",
941 "SVOP",
942 "PADOP",
943 "PVOP",
944 "LOOP",
945 "COP",
946 "METHOP",
947 "UNOP_AUX",
948};
949
950
951/* dump an op and any children. level indicates the initial indent.
952 * The bits of bar indicate which indents should receive a vertical bar.
953 * For example if level == 5 and bar == 0b01101, then the indent prefix
954 * emitted will be (not including the <>'s):
955 *
956 * < | | | >
957 * 55554444333322221111
958 *
959 * For heavily nested output, the level may exceed the number of bits
960 * in bar; in this case the first few columns in the output will simply
961 * not have a bar, which is harmless.
962 */
963
964static void
965S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
79072805 966{
e15d5972
AL
967 const OPCODE optype = o->op_type;
968
7918f24d
NC
969 PERL_ARGS_ASSERT_DO_OP_DUMP;
970
cd6e4874
DM
971 /* print op header line */
972
973 S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o));
974
975 if (optype == OP_NULL && o->op_targ)
976 PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]);
977
978 PerlIO_printf(file, " %s(0x%" UVxf ")",
979 op_class_names[op_class(o)], PTR2UV(o));
980 S_opdump_link(aTHX_ o->op_next, file);
981
982 /* print op common fields */
983
984 if (o->op_targ && optype != OP_NULL)
985 S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n",
986 (long)o->op_targ);
a7fd8ef6 987
760f8c06
DM
988 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
989 SV * const tmpsv = newSVpvs("");
990 switch (o->op_flags & OPf_WANT) {
991 case OPf_WANT_VOID:
992 sv_catpv(tmpsv, ",VOID");
993 break;
994 case OPf_WANT_SCALAR:
995 sv_catpv(tmpsv, ",SCALAR");
996 break;
997 case OPf_WANT_LIST:
998 sv_catpv(tmpsv, ",LIST");
999 break;
1000 default:
1001 sv_catpv(tmpsv, ",UNKNOWN");
1002 break;
1003 }
1004 append_flags(tmpsv, o->op_flags, op_flags_names);
1005 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
1006 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
1007 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
1008 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
87b5a8b9 1009 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
cd6e4874 1010 S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n",
760f8c06
DM
1011 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
1012 }
1013
1014 if (o->op_private) {
f3574cc6
DM
1015 U16 oppriv = o->op_private;
1016 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
1017 SV * tmpsv = NULL;
1018
1019 if (op_ix != -1) {
1020 U16 stop = 0;
1021 tmpsv = newSVpvs("");
1022 for (; !stop; op_ix++) {
1023 U16 entry = PL_op_private_bitdefs[op_ix];
1024 U16 bit = (entry >> 2) & 7;
1025 U16 ix = entry >> 5;
1026
1027 stop = (entry & 1);
1028
1029 if (entry & 2) {
1030 /* bitfield */
1031 I16 const *p = &PL_op_private_bitfields[ix];
1032 U16 bitmin = (U16) *p++;
1033 I16 label = *p++;
1034 I16 enum_label;
1035 U16 mask = 0;
1036 U16 i;
1037 U16 val;
1038
1039 for (i = bitmin; i<= bit; i++)
1040 mask |= (1<<i);
1041 bit = bitmin;
1042 val = (oppriv & mask);
1043
1044 if ( label != -1
1045 && PL_op_private_labels[label] == '-'
1046 && PL_op_private_labels[label+1] == '\0'
1047 )
1048 /* display as raw number */
1049 continue;
1050
1051 oppriv -= val;
1052 val >>= bit;
1053 enum_label = -1;
1054 while (*p != -1) {
1055 if (val == *p++) {
1056 enum_label = *p;
1057 break;
1058 }
1059 p++;
1060 }
1061 if (val == 0 && enum_label == -1)
1062 /* don't display anonymous zero values */
1063 continue;
1064
1065 sv_catpv(tmpsv, ",");
1066 if (label != -1) {
1067 sv_catpv(tmpsv, &PL_op_private_labels[label]);
1068 sv_catpv(tmpsv, "=");
1069 }
95268469 1070 if (enum_label == -1)
147e3846 1071 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
95268469
DM
1072 else
1073 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
f3574cc6
DM
1074
1075 }
1076 else {
1077 /* bit flag */
1078 if ( oppriv & (1<<bit)
1079 && !(PL_op_private_labels[ix] == '-'
1080 && PL_op_private_labels[ix+1] == '\0'))
1081 {
1082 oppriv -= (1<<bit);
1083 sv_catpv(tmpsv, ",");
1084 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
1085 }
760f8c06 1086 }
760f8c06 1087 }
f3574cc6
DM
1088 if (oppriv) {
1089 sv_catpv(tmpsv, ",");
147e3846 1090 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
760f8c06
DM
1091 }
1092 }
f3574cc6 1093 if (tmpsv && SvCUR(tmpsv)) {
cd6e4874
DM
1094 S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n",
1095 SvPVX_const(tmpsv) + 1);
760f8c06 1096 } else
cd6e4874
DM
1097 S_opdump_indent(aTHX_ o, level, bar, file,
1098 "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv);
760f8c06
DM
1099 }
1100
e15d5972 1101 switch (optype) {
971a9dd3 1102 case OP_AELEMFAST:
93a17b20 1103 case OP_GVSV:
79072805 1104 case OP_GV:
971a9dd3 1105#ifdef USE_ITHREADS
cd6e4874
DM
1106 S_opdump_indent(aTHX_ o, level, bar, file,
1107 "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
971a9dd3 1108#else
e18c4116
DM
1109 S_opdump_indent(aTHX_ o, level, bar, file,
1110 "GV = %" SVf " (0x%" UVxf ")\n",
1111 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
971a9dd3 1112#endif
79072805 1113 break;
fedf30e1
DM
1114
1115 case OP_MULTIDEREF:
1116 {
1117 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
1118 UV i, count = items[-1].uv;
1119
cd6e4874 1120 S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n");
fedf30e1 1121 for (i=0; i < count; i++)
cd6e4874
DM
1122 S_opdump_indent(aTHX_ o, level+1, (bar << 1), file,
1123 "%" UVuf " => 0x%" UVxf "\n",
fedf30e1 1124 i, items[i].uv);
1e9f2263 1125 break;
fedf30e1
DM
1126 }
1127
79072805 1128 case OP_CONST:
996c9baa 1129 case OP_HINTSEVAL:
f5d5a27c 1130 case OP_METHOD_NAMED:
7d6c333c 1131 case OP_METHOD_SUPER:
810bd8b7 1132 case OP_METHOD_REDIR:
1133 case OP_METHOD_REDIR_SUPER:
b6a15bc5
DM
1134#ifndef USE_ITHREADS
1135 /* with ITHREADS, consts are stored in the pad, and the right pad
1136 * may not be active here, so skip */
cd6e4874
DM
1137 S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n",
1138 SvPEEK(cMETHOPx_meth(o)));
b6a15bc5 1139#endif
79072805 1140 break;
5e412b02
FC
1141 case OP_NULL:
1142 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
1143 break;
1144 /* FALLTHROUGH */
93a17b20
LW
1145 case OP_NEXTSTATE:
1146 case OP_DBSTATE:
57843af0 1147 if (CopLINE(cCOPo))
cd6e4874 1148 S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n",
9d98dee5 1149 (UV)CopLINE(cCOPo));
5219f5ec
DM
1150
1151 if (CopSTASHPV(cCOPo)) {
1152 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1153 HV *stash = CopSTASH(cCOPo);
1154 const char * const hvname = HvNAME_get(stash);
1155
1156 S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n",
1157 generic_pv_escape(tmpsv, hvname,
1158 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1159 }
1160
1161 if (CopLABEL(cCOPo)) {
1162 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1163 STRLEN label_len;
1164 U32 label_flags;
1165 const char *label = CopLABEL_len_flags(cCOPo,
1166 &label_len, &label_flags);
1167 S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n",
1168 generic_pv_escape( tmpsv, label, label_len,
1169 (label_flags & SVf_UTF8)));
1170 }
1171
cd6e4874 1172 S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n",
947a9e0f 1173 (unsigned int)cCOPo->cop_seq);
79072805 1174 break;
cd6e4874
DM
1175
1176 case OP_ENTERITER:
79072805 1177 case OP_ENTERLOOP:
cd6e4874
DM
1178 S_opdump_indent(aTHX_ o, level, bar, file, "REDO");
1179 S_opdump_link(aTHX_ cLOOPo->op_redoop, file);
1180 S_opdump_indent(aTHX_ o, level, bar, file, "NEXT");
1181 S_opdump_link(aTHX_ cLOOPo->op_nextop, file);
1182 S_opdump_indent(aTHX_ o, level, bar, file, "LAST");
1183 S_opdump_link(aTHX_ cLOOPo->op_lastop, file);
79072805 1184 break;
cd6e4874
DM
1185
1186 case OP_REGCOMP:
1187 case OP_SUBSTCONT:
79072805 1188 case OP_COND_EXPR:
1a67a97c 1189 case OP_RANGE:
a0d0e21e 1190 case OP_MAPWHILE:
79072805
LW
1191 case OP_GREPWHILE:
1192 case OP_OR:
cd6e4874 1193 case OP_DOR:
79072805 1194 case OP_AND:
cd6e4874
DM
1195 case OP_ORASSIGN:
1196 case OP_DORASSIGN:
1197 case OP_ANDASSIGN:
1198 case OP_ARGDEFELEM:
1199 case OP_ENTERGIVEN:
1200 case OP_ENTERWHEN:
1201 case OP_ENTERTRY:
1202 case OP_ONCE:
1203 S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
1204 S_opdump_link(aTHX_ cLOGOPo->op_other, file);
79072805 1205 break;
5012eebe 1206 case OP_SPLIT:
79072805 1207 case OP_MATCH:
8782bef2 1208 case OP_QR:
79072805 1209 case OP_SUBST:
cd6e4874 1210 S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo);
79072805 1211 break;
7934575e
GS
1212 case OP_LEAVE:
1213 case OP_LEAVEEVAL:
1214 case OP_LEAVESUB:
1215 case OP_LEAVESUBLV:
1216 case OP_LEAVEWRITE:
1217 case OP_SCOPE:
1218 if (o->op_private & OPpREFCOUNTED)
cd6e4874
DM
1219 S_opdump_indent(aTHX_ o, level, bar, file,
1220 "REFCNT = %" UVuf "\n", (UV)o->op_targ);
7934575e 1221 break;
abd07ec0
DM
1222
1223 case OP_DUMP:
1224 case OP_GOTO:
1225 case OP_NEXT:
1226 case OP_LAST:
1227 case OP_REDO:
1228 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
1229 break;
abd07ec0
DM
1230 {
1231 SV * const label = newSVpvs_flags("", SVs_TEMP);
1232 generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
1233 S_opdump_indent(aTHX_ o, level, bar, file,
1234 "PV = \"%" SVf "\" (0x%" UVxf ")\n",
1235 SVfARG(label), PTR2UV(cPVOPo->op_pv));
f49e8464 1236 break;
abd07ec0
DM
1237 }
1238
f49e8464
DM
1239 case OP_TRANS:
1240 case OP_TRANSR:
1241 S_opdump_indent(aTHX_ o, level, bar, file,
1242 "PV = 0x%" UVxf "\n",
1243 PTR2UV(cPVOPo->op_pv));
1244 break;
1245
abd07ec0 1246
a0d0e21e
LW
1247 default:
1248 break;
79072805 1249 }
11343788 1250 if (o->op_flags & OPf_KIDS) {
79072805 1251 OP *kid;
cd6e4874
DM
1252 level++;
1253 bar <<= 1;
e6dae479 1254 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
cd6e4874
DM
1255 S_do_op_dump_bar(aTHX_ level,
1256 (bar | cBOOL(OpHAS_SIBLING(kid))),
1257 file, kid);
8d063cd8 1258 }
3967c732
JD
1259}
1260
cd6e4874
DM
1261
1262void
1263Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1264{
1265 S_do_op_dump_bar(aTHX_ level, 0, file, o);
1266}
1267
1268
36b1c95c
MH
1269/*
1270=for apidoc op_dump
1271
1272Dumps the optree starting at OP C<o> to C<STDERR>.
1273
1274=cut
1275*/
1276
3967c732 1277void
6867be6d 1278Perl_op_dump(pTHX_ const OP *o)
3967c732 1279{
7918f24d 1280 PERL_ARGS_ASSERT_OP_DUMP;
3967c732 1281 do_op_dump(0, Perl_debug_log, o);
8d063cd8
LW
1282}
1283
8adcabd8 1284void
864dbfa3 1285Perl_gv_dump(pTHX_ GV *gv)
378cc40b 1286{
0eb335df
BF
1287 STRLEN len;
1288 const char* name;
1289 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1290
79072805 1291 if (!gv) {
760ac839 1292 PerlIO_printf(Perl_debug_log, "{}\n");
378cc40b
LW
1293 return;
1294 }
8990e307 1295 sv = sv_newmortal();
760ac839 1296 PerlIO_printf(Perl_debug_log, "{\n");
bd61b366 1297 gv_fullname3(sv, gv, NULL);
0eb335df
BF
1298 name = SvPV_const(sv, len);
1299 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1300 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
79072805 1301 if (gv != GvEGV(gv)) {
bd61b366 1302 gv_efullname3(sv, GvEGV(gv), NULL);
0eb335df
BF
1303 name = SvPV_const(sv, len);
1304 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1305 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
8adcabd8 1306 }
38d7fd8b 1307 (void)PerlIO_putc(Perl_debug_log, '\n');
cea2e8a9 1308 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
8d063cd8
LW
1309}
1310
14befaf4 1311
afe38520 1312/* map magic types to the symbolic names
14befaf4
DM
1313 * (with the PERL_MAGIC_ prefixed stripped)
1314 */
1315
27da23d5 1316static const struct { const char type; const char *name; } magic_names[] = {
16bc0f48 1317#include "mg_names.inc"
516a5887 1318 /* this null string terminates the list */
b9ac451d 1319 { 0, NULL },
14befaf4
DM
1320};
1321
8adcabd8 1322void
6867be6d 1323Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
8d063cd8 1324{
7918f24d
NC
1325 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1326
3967c732 1327 for (; mg; mg = mg->mg_moremagic) {
b900a521 1328 Perl_dump_indent(aTHX_ level, file,
147e3846 1329 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
3967c732 1330 if (mg->mg_virtual) {
bfed75c6 1331 const MGVTBL * const v = mg->mg_virtual;
2d1f1fe5
NC
1332 if (v >= PL_magic_vtables
1333 && v < PL_magic_vtables + magic_vtable_max) {
1334 const U32 i = v - PL_magic_vtables;
1335 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1336 }
3967c732 1337 else
147e3846
KW
1338 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1339 UVxf "\n", PTR2UV(v));
3967c732
JD
1340 }
1341 else
cea2e8a9 1342 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
8d063cd8 1343
3967c732 1344 if (mg->mg_private)
cea2e8a9 1345 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
3967c732 1346
14befaf4
DM
1347 {
1348 int n;
c445ea15 1349 const char *name = NULL;
27da23d5 1350 for (n = 0; magic_names[n].name; n++) {
14befaf4
DM
1351 if (mg->mg_type == magic_names[n].type) {
1352 name = magic_names[n].name;
1353 break;
1354 }
1355 }
1356 if (name)
1357 Perl_dump_indent(aTHX_ level, file,
1358 " MG_TYPE = PERL_MAGIC_%s\n", name);
1359 else
1360 Perl_dump_indent(aTHX_ level, file,
1361 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1362 }
3967c732
JD
1363
1364 if (mg->mg_flags) {
cea2e8a9 1365 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
cb50f42d
YST
1366 if (mg->mg_type == PERL_MAGIC_envelem &&
1367 mg->mg_flags & MGf_TAINTEDDIR)
cea2e8a9 1368 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
4c02285a
FR
1369 if (mg->mg_type == PERL_MAGIC_regex_global &&
1370 mg->mg_flags & MGf_MINMATCH)
1371 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
3967c732 1372 if (mg->mg_flags & MGf_REFCOUNTED)
cea2e8a9 1373 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1374 if (mg->mg_flags & MGf_GSKIP)
cea2e8a9 1375 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
4c02285a
FR
1376 if (mg->mg_flags & MGf_COPY)
1377 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1378 if (mg->mg_flags & MGf_DUP)
1379 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1380 if (mg->mg_flags & MGf_LOCAL)
1381 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
25fdce4a
FC
1382 if (mg->mg_type == PERL_MAGIC_regex_global &&
1383 mg->mg_flags & MGf_BYTES)
1384 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
3967c732
JD
1385 }
1386 if (mg->mg_obj) {
147e3846 1387 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
28d8d7f4
YO
1388 PTR2UV(mg->mg_obj));
1389 if (mg->mg_type == PERL_MAGIC_qr) {
07bc277f 1390 REGEXP* const re = (REGEXP *)mg->mg_obj;
61f9802b 1391 SV * const dsv = sv_newmortal();
866c78d1 1392 const char * const s
4c02285a 1393 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
28d8d7f4 1394 60, NULL, NULL,
95b611b0 1395 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
3c8556c3 1396 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
28d8d7f4 1397 );
6483fb35 1398 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
147e3846 1399 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
07bc277f 1400 (IV)RX_REFCNT(re));
28d8d7f4
YO
1401 }
1402 if (mg->mg_flags & MGf_REFCOUNTED)
3967c732
JD
1403 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1404 }
1405 if (mg->mg_len)
894356b3 1406 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1407 if (mg->mg_ptr) {
147e3846 1408 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
3967c732 1409 if (mg->mg_len >= 0) {
7e8c5dac 1410 if (mg->mg_type != PERL_MAGIC_utf8) {
17605be7 1411 SV * const sv = newSVpvs("");
7e8c5dac 1412 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
17605be7 1413 SvREFCNT_dec_NN(sv);
7e8c5dac 1414 }
3967c732
JD
1415 }
1416 else if (mg->mg_len == HEf_SVKEY) {
1417 PerlIO_puts(file, " => HEf_SVKEY\n");
ad64d0ec
NC
1418 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1419 maxnest, dumpops, pvlim); /* MG is already +1 */
3967c732
JD
1420 continue;
1421 }
866f9d6c 1422 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
3967c732 1423 else
866f9d6c
FC
1424 PerlIO_puts(
1425 file,
1426 " ???? - " __FILE__
1427 " does not know how to handle this MG_LEN"
1428 );
38d7fd8b 1429 (void)PerlIO_putc(file, '\n');
3967c732 1430 }
7e8c5dac 1431 if (mg->mg_type == PERL_MAGIC_utf8) {
61f9802b 1432 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7e8c5dac
HS
1433 if (cache) {
1434 IV i;
1435 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1436 Perl_dump_indent(aTHX_ level, file,
147e3846 1437 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
7e8c5dac
HS
1438 i,
1439 (UV)cache[i * 2],
1440 (UV)cache[i * 2 + 1]);
1441 }
1442 }
378cc40b 1443 }
3967c732
JD
1444}
1445
1446void
6867be6d 1447Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1448{
b9ac451d 1449 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732
JD
1450}
1451
1452void
e1ec3a88 1453Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1454{
bfcb3514 1455 const char *hvname;
7918f24d
NC
1456
1457 PERL_ARGS_ASSERT_DO_HV_DUMP;
1458
147e3846 1459 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
bfcb3514 1460 if (sv && (hvname = HvNAME_get(sv)))
d7d51f4b
YO
1461 {
1462 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1463 name which quite legally could contain insane things like tabs, newlines, nulls or
1464 other scary crap - this should produce sane results - except maybe for unicode package
1465 names - but we will wait for someone to file a bug on that - demerphq */
0eb335df
BF
1466 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1467 PerlIO_printf(file, "\t\"%s\"\n",
1468 generic_pv_escape( tmpsv, hvname,
1469 HvNAMELEN(sv), HvNAMEUTF8(sv)));
d7d51f4b 1470 }
79072805 1471 else
38d7fd8b 1472 (void)PerlIO_putc(file, '\n');
3967c732
JD
1473}
1474
1475void
e1ec3a88 1476Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1477{
7918f24d
NC
1478 PERL_ARGS_ASSERT_DO_GV_DUMP;
1479
147e3846 1480 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
0eb335df
BF
1481 if (sv && GvNAME(sv)) {
1482 SV * const tmpsv = newSVpvs("");
1483 PerlIO_printf(file, "\t\"%s\"\n",
1484 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1485 }
c90c0ff4 1486 else
38d7fd8b 1487 (void)PerlIO_putc(file, '\n');
3967c732
JD
1488}
1489
1490void
e1ec3a88 1491Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1492{
7918f24d
NC
1493 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1494
147e3846 1495 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
3967c732 1496 if (sv && GvNAME(sv)) {
0eb335df 1497 SV *tmp = newSVpvs_flags("", SVs_TEMP);
bfcb3514 1498 const char *hvname;
0eb335df
BF
1499 HV * const stash = GvSTASH(sv);
1500 PerlIO_printf(file, "\t");
6f3289f0 1501 /* TODO might have an extra \" here */
0eb335df
BF
1502 if (stash && (hvname = HvNAME_get(stash))) {
1503 PerlIO_printf(file, "\"%s\" :: \"",
1504 generic_pv_escape(tmp, hvname,
1505 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1506 }
1507 PerlIO_printf(file, "%s\"\n",
1508 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
8d063cd8 1509 }
3967c732 1510 else
38d7fd8b 1511 (void)PerlIO_putc(file, '\n');
3967c732
JD
1512}
1513
a0c2f4dd
NC
1514const struct flag_to_name first_sv_flags_names[] = {
1515 {SVs_TEMP, "TEMP,"},
1516 {SVs_OBJECT, "OBJECT,"},
1517 {SVs_GMG, "GMG,"},
1518 {SVs_SMG, "SMG,"},
1519 {SVs_RMG, "RMG,"},
1520 {SVf_IOK, "IOK,"},
1521 {SVf_NOK, "NOK,"},
1522 {SVf_POK, "POK,"}
1523};
1524
1525const struct flag_to_name second_sv_flags_names[] = {
1526 {SVf_OOK, "OOK,"},
1527 {SVf_FAKE, "FAKE,"},
1528 {SVf_READONLY, "READONLY,"},
fd01b4b7 1529 {SVf_PROTECT, "PROTECT,"},
a0c2f4dd 1530 {SVf_BREAK, "BREAK,"},
a0c2f4dd
NC
1531 {SVp_IOK, "pIOK,"},
1532 {SVp_NOK, "pNOK,"},
1533 {SVp_POK, "pPOK,"}
1534};
1535
ae1f06a1
NC
1536const struct flag_to_name cv_flags_names[] = {
1537 {CVf_ANON, "ANON,"},
1538 {CVf_UNIQUE, "UNIQUE,"},
1539 {CVf_CLONE, "CLONE,"},
1540 {CVf_CLONED, "CLONED,"},
1541 {CVf_CONST, "CONST,"},
1542 {CVf_NODEBUG, "NODEBUG,"},
1543 {CVf_LVALUE, "LVALUE,"},
1544 {CVf_METHOD, "METHOD,"},
cfc1e951 1545 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1546 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1547 {CVf_DYNFILE, "DYNFILE,"},
8fa6a409 1548 {CVf_AUTOLOAD, "AUTOLOAD,"},
e4555ecf 1549 {CVf_HASEVAL, "HASEVAL,"},
bfbc3ad9 1550 {CVf_SLABBED, "SLABBED,"},
bf9a4d2d 1551 {CVf_NAMED, "NAMED,"},
82487b59 1552 {CVf_LEXICAL, "LEXICAL,"},
31d45e0c 1553 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC
1554};
1555
1556const struct flag_to_name hv_flags_names[] = {
1557 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1558 {SVphv_LAZYDEL, "LAZYDEL,"},
1559 {SVphv_HASKFLAGS, "HASKFLAGS,"},
45eaf8af 1560 {SVf_AMAGIC, "OVERLOAD,"},
ae1f06a1
NC
1561 {SVphv_CLONEABLE, "CLONEABLE,"}
1562};
1563
1564const struct flag_to_name gp_flags_names[] = {
1565 {GVf_INTRO, "INTRO,"},
1566 {GVf_MULTI, "MULTI,"},
1567 {GVf_ASSUMECV, "ASSUMECV,"},
ae1f06a1
NC
1568};
1569
1570const struct flag_to_name gp_flags_imported_names[] = {
1571 {GVf_IMPORTED_SV, " SV"},
1572 {GVf_IMPORTED_AV, " AV"},
1573 {GVf_IMPORTED_HV, " HV"},
1574 {GVf_IMPORTED_CV, " CV"},
1575};
1576
0d331aaf
YO
1577/* NOTE: this structure is mostly duplicative of one generated by
1578 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1579 * the two. - Yves */
e3e400ec 1580const struct flag_to_name regexp_extflags_names[] = {
d63e6659
DM
1581 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1582 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1583 {RXf_PMf_FOLD, "PMf_FOLD,"},
1584 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
334afb3e 1585 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
d63e6659 1586 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
41d7c59e 1587 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
8e1490ee 1588 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
dbc200c5 1589 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
d63e6659 1590 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
d63e6659
DM
1591 {RXf_CHECK_ALL, "CHECK_ALL,"},
1592 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1593 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1594 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1595 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
dbc200c5 1596 {RXf_SPLIT, "SPLIT,"},
d63e6659
DM
1597 {RXf_COPY_DONE, "COPY_DONE,"},
1598 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1599 {RXf_TAINTED, "TAINTED,"},
1600 {RXf_START_ONLY, "START_ONLY,"},
dbc200c5 1601 {RXf_SKIPWHITE, "SKIPWHITE,"},
d63e6659
DM
1602 {RXf_WHITE, "WHITE,"},
1603 {RXf_NULL, "NULL,"},
1604};
1605
0d331aaf
YO
1606/* NOTE: this structure is mostly duplicative of one generated by
1607 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1608 * the two. - Yves */
e3e400ec
YO
1609const struct flag_to_name regexp_core_intflags_names[] = {
1610 {PREGf_SKIP, "SKIP,"},
0d331aaf
YO
1611 {PREGf_IMPLICIT, "IMPLICIT,"},
1612 {PREGf_NAUGHTY, "NAUGHTY,"},
e3e400ec
YO
1613 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1614 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
0d331aaf 1615 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
e3e400ec 1616 {PREGf_NOSCAN, "NOSCAN,"},
58430ea8
YO
1617 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1618 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
8e1490ee
YO
1619 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1620 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1621 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
e3e400ec
YO
1622};
1623
c24d0595
DM
1624/* Perl_do_sv_dump():
1625 *
1626 * level: amount to indent the output
1627 * sv: the object to dump
1628 * nest: the current level of recursion
1629 * maxnest: the maximum allowed level of recursion
1630 * dumpops: if true, also dump the ops associated with a CV
1631 * pvlim: limit on the length of any strings that are output
1632 * */
1633
3967c732 1634void
864dbfa3 1635Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1636{
cea89e20 1637 SV *d;
e1ec3a88 1638 const char *s;
3967c732
JD
1639 U32 flags;
1640 U32 type;
1641
7918f24d
NC
1642 PERL_ARGS_ASSERT_DO_SV_DUMP;
1643
3967c732 1644 if (!sv) {
cea2e8a9 1645 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1646 return;
378cc40b 1647 }
2ef28da1 1648
3967c732
JD
1649 flags = SvFLAGS(sv);
1650 type = SvTYPE(sv);
79072805 1651
e0bbf362
DM
1652 /* process general SV flags */
1653
cea89e20 1654 d = Perl_newSVpvf(aTHX_
147e3846 1655 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
56431972 1656 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS
1657 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1658 (int)(PL_dumpindent*level), "");
8d063cd8 1659
0f94cb1f 1660 if ((flags & SVs_PADSTALE))
9a214eec 1661 sv_catpv(d, "PADSTALE,");
0f94cb1f 1662 if ((flags & SVs_PADTMP))
9a214eec 1663 sv_catpv(d, "PADTMP,");
a0c2f4dd 1664 append_flags(d, flags, first_sv_flags_names);
810b8aa5
GS
1665 if (flags & SVf_ROK) {
1666 sv_catpv(d, "ROK,");
1667 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1668 }
45eaf8af 1669 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
a0c2f4dd 1670 append_flags(d, flags, second_sv_flags_names);
7db6405c
FC
1671 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1672 && type != SVt_PVAV) {
1ccdb730
NC
1673 if (SvPCS_IMPORTED(sv))
1674 sv_catpv(d, "PCS_IMPORTED,");
1675 else
9660f481 1676 sv_catpv(d, "SCREAM,");
1ccdb730 1677 }
3967c732 1678
e0bbf362
DM
1679 /* process type-specific SV flags */
1680
3967c732
JD
1681 switch (type) {
1682 case SVt_PVCV:
1683 case SVt_PVFM:
ae1f06a1 1684 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD
1685 break;
1686 case SVt_PVHV:
ae1f06a1 1687 append_flags(d, flags, hv_flags_names);
3967c732 1688 break;
926fc7b6
DM
1689 case SVt_PVGV:
1690 case SVt_PVLV:
1691 if (isGV_with_GP(sv)) {
ae1f06a1 1692 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1693 }
926fc7b6 1694 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD
1695 sv_catpv(d, "IMPORT");
1696 if (GvIMPORTED(sv) == GVf_IMPORTED)
1697 sv_catpv(d, "ALL,");
1698 else {
1699 sv_catpv(d, "(");
ae1f06a1 1700 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
3967c732
JD
1701 sv_catpv(d, " ),");
1702 }
1703 }
924ba076 1704 /* FALLTHROUGH */
a5c7cb08 1705 case SVt_PVMG:
25da4f38 1706 default:
69c678eb 1707 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1708 break;
a5c7cb08 1709
11ca45c0
NC
1710 case SVt_PVAV:
1711 break;
3967c732 1712 }
86f0d186
NC
1713 /* SVphv_SHAREKEYS is also 0x20000000 */
1714 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1715 sv_catpv(d, "UTF8");
3967c732 1716
b162af07
SP
1717 if (*(SvEND(d) - 1) == ',') {
1718 SvCUR_set(d, SvCUR(d) - 1);
1719 SvPVX(d)[SvCUR(d)] = '\0';
1720 }
3967c732 1721 sv_catpv(d, ")");
b15aece3 1722 s = SvPVX_const(d);
3967c732 1723
e0bbf362
DM
1724 /* dump initial SV details */
1725
fd0854ff 1726#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1727 Perl_dump_indent(aTHX_ level, file,
147e3846 1728 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
fd0854ff
DM
1729 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1730 sv->sv_debug_line,
1731 sv->sv_debug_inpad ? "for" : "by",
1732 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1733 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM
1734 sv->sv_debug_serial
1735 );
fd0854ff 1736#endif
cea2e8a9 1737 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM
1738
1739 /* Dump SV type */
1740
5357ca29
NC
1741 if (type < SVt_LAST) {
1742 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1743
1744 if (type == SVt_NULL) {
5f954473 1745 SvREFCNT_dec_NN(d);
5357ca29
NC
1746 return;
1747 }
1748 } else {
147e3846 1749 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
5f954473 1750 SvREFCNT_dec_NN(d);
3967c732
JD
1751 return;
1752 }
e0bbf362
DM
1753
1754 /* Dump general SV fields */
1755
27bd069f 1756 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC
1757 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1758 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1759 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1760 if (SvIsUV(sv)
765f542d 1761 )
147e3846 1762 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
cf2093f6 1763 else
147e3846 1764 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
38d7fd8b 1765 (void)PerlIO_putc(file, '\n');
3967c732 1766 }
e0bbf362 1767
0f94cb1f 1768 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1769 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1770 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1771 || type == SVt_NV) {
67d796ae 1772 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
88cb8500 1773 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
67d796ae 1774 RESTORE_LC_NUMERIC_UNDERLYING();
3967c732 1775 }
e0bbf362 1776
3967c732 1777 if (SvROK(sv)) {
147e3846
KW
1778 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1779 PTR2UV(SvRV(sv)));
3967c732
JD
1780 if (nest < maxnest)
1781 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1782 }
e0bbf362 1783
cea89e20 1784 if (type < SVt_PV) {
5f954473 1785 SvREFCNT_dec_NN(d);
3967c732 1786 return;
cea89e20 1787 }
e0bbf362 1788
5a3c7349
FC
1789 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1790 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
8d919b0a
FC
1791 const bool re = isREGEXP(sv);
1792 const char * const ptr =
1793 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1794 if (ptr) {
69240efd 1795 STRLEN delta;
7a4bba22 1796 if (SvOOK(sv)) {
69240efd 1797 SvOOK_offset(sv, delta);
147e3846 1798 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
5186cc12 1799 (UV) delta);
69240efd
NC
1800 } else {
1801 delta = 0;
7a4bba22 1802 }
147e3846
KW
1803 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1804 PTR2UV(ptr));
7a4bba22
NC
1805 if (SvOOK(sv)) {
1806 PerlIO_printf(file, "( %s . ) ",
8d919b0a 1807 pv_display(d, ptr - delta, delta, 0,
7a4bba22
NC
1808 pvlim));
1809 }
ad3f05ad
KW
1810 if (type == SVt_INVLIST) {
1811 PerlIO_printf(file, "\n");
1812 /* 4 blanks indents 2 beyond the PV, etc */
1813 _invlist_dump(file, level, " ", sv);
1814 }
1815 else {
685bfc3c
KW
1816 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1817 re ? 0 : SvLEN(sv),
1818 pvlim));
1819 if (SvUTF8(sv)) /* the 6? \x{....} */
1820 PerlIO_printf(file, " [UTF8 \"%s\"]",
1821 sv_uni_display(d, sv, 6 * SvCUR(sv),
1822 UNI_DISPLAY_QQ));
1823 PerlIO_printf(file, "\n");
ad3f05ad 1824 }
147e3846 1825 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
8d919b0a 1826 if (!re)
147e3846 1827 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
8d919b0a 1828 (IV)SvLEN(sv));
93c10d60 1829#ifdef PERL_COPY_ON_WRITE
db2c6cb3
FC
1830 if (SvIsCOW(sv) && SvLEN(sv))
1831 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1832 CowREFCNT(sv));
1833#endif
3967c732
JD
1834 }
1835 else
cea2e8a9 1836 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1837 }
e0bbf362 1838
3967c732 1839 if (type >= SVt_PVMG) {
0f94cb1f 1840 if (SvMAGIC(sv))
8530ff28 1841 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
3967c732
JD
1842 if (SvSTASH(sv))
1843 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC
1844
1845 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
147e3846
KW
1846 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1847 (IV)BmUSEFUL(sv));
c13a5c80 1848 }
3967c732 1849 }
e0bbf362
DM
1850
1851 /* Dump type-specific SV fields */
1852
3967c732 1853 switch (type) {
3967c732 1854 case SVt_PVAV:
147e3846
KW
1855 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1856 PTR2UV(AvARRAY(sv)));
3967c732 1857 if (AvARRAY(sv) != AvALLOC(sv)) {
147e3846
KW
1858 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1859 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1860 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1861 PTR2UV(AvALLOC(sv)));
3967c732
JD
1862 }
1863 else
38d7fd8b 1864 (void)PerlIO_putc(file, '\n');
147e3846
KW
1865 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1866 (IV)AvFILLp(sv));
1867 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1868 (IV)AvMAX(sv));
ed0faf2e 1869 SvPVCLEAR(d);
11ca45c0
NC
1870 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1871 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP
1872 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1873 SvCUR(d) ? SvPVX_const(d) + 1 : "");
476fafda 1874 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
c70927a6 1875 SSize_t count;
476fafda
DM
1876 SV **svp = AvARRAY(MUTABLE_AV(sv));
1877 for (count = 0;
1878 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1879 count++, svp++)
1880 {
1881 SV* const elt = *svp;
147e3846
KW
1882 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1883 (IV)count);
476fafda 1884 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
3967c732
JD
1885 }
1886 }
1887 break;
5d27ee4a
DD
1888 case SVt_PVHV: {
1889 U32 usedkeys;
0c22a733
DM
1890 if (SvOOK(sv)) {
1891 struct xpvhv_aux *const aux = HvAUX(sv);
147e3846 1892 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
0c22a733
DM
1893 (UV)aux->xhv_aux_flags);
1894 }
147e3846 1895 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1186f821 1896 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
5d27ee4a 1897 if (HvARRAY(sv) && usedkeys) {
3967c732
JD
1898 /* Show distribution of HEs in the ARRAY */
1899 int freq[200];
c3caa5c3 1900#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
3967c732
JD
1901 int i;
1902 int max = 0;
5d27ee4a 1903 U32 pow2 = 2, keys = usedkeys;
65202027 1904 NV theoret, sum = 0;
3967c732
JD
1905
1906 PerlIO_printf(file, " (");
1907 Zero(freq, FREQ_MAX + 1, int);
eb160463 1908 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL
1909 HE* h;
1910 int count = 0;
3967c732
JD
1911 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1912 count++;
1913 if (count > FREQ_MAX)
1914 count = FREQ_MAX;
1915 freq[count]++;
1916 if (max < count)
1917 max = count;
1918 }
1919 for (i = 0; i <= max; i++) {
1920 if (freq[i]) {
1921 PerlIO_printf(file, "%d%s:%d", i,
1922 (i == FREQ_MAX) ? "+" : "",
1923 freq[i]);
1924 if (i != max)
1925 PerlIO_printf(file, ", ");
1926 }
1927 }
38d7fd8b 1928 (void)PerlIO_putc(file, ')');
b8fa94d8
MG
1929 /* The "quality" of a hash is defined as the total number of
1930 comparisons needed to access every element once, relative
1931 to the expected number needed for a random hash.
1932
1933 The total number of comparisons is equal to the sum of
e76cd0fa
AMS
1934 the squares of the number of entries in each bucket.
1935 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG
1936 value is
1937 n + n(n-1)/2k
1938 */
1939
3967c732
JD
1940 for (i = max; i > 0; i--) { /* Precision: count down. */
1941 sum += freq[i] * i * i;
1942 }
155aba94 1943 while ((keys = keys >> 1))
3967c732 1944 pow2 = pow2 << 1;
5d27ee4a 1945 theoret = usedkeys;
b8fa94d8 1946 theoret += theoret * (theoret-1)/pow2;
38d7fd8b 1947 (void)PerlIO_putc(file, '\n');
147e3846
KW
1948 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
1949 NVff "%%", theoret/sum*100);
3967c732 1950 }
38d7fd8b 1951 (void)PerlIO_putc(file, '\n');
147e3846
KW
1952 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
1953 (IV)usedkeys);
9faf471a
NC
1954 {
1955 STRLEN count = 0;
1956 HE **ents = HvARRAY(sv);
1957
1958 if (ents) {
1959 HE *const *const last = ents + HvMAX(sv);
1960 count = last + 1 - ents;
1961
1962 do {
1963 if (!*ents)
1964 --count;
1965 } while (++ents <= last);
1966 }
1967
147e3846 1968 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
8bf4c401 1969 (UV)count);
9faf471a 1970 }
147e3846
KW
1971 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1972 (IV)HvMAX(sv));
e1a7ec8d 1973 if (SvOOK(sv)) {
147e3846
KW
1974 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
1975 (IV)HvRITER_get(sv));
1976 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
1977 PTR2UV(HvEITER_get(sv)));
6a5b4183 1978#ifdef PERL_HASH_RANDOMIZE_KEYS
147e3846
KW
1979 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
1980 (UV)HvRAND_get(sv));
e1a7ec8d 1981 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
147e3846
KW
1982 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
1983 (UV)HvLASTRAND_get(sv));
e1a7ec8d 1984 }
6a5b4183 1985#endif
38d7fd8b 1986 (void)PerlIO_putc(file, '\n');
e1a7ec8d 1987 }
8d2f4536 1988 {
b9ac451d 1989 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536 1990 if (mg && mg->mg_obj) {
147e3846 1991 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
8d2f4536
NC
1992 }
1993 }
bfcb3514 1994 {
b9ac451d 1995 const char * const hvname = HvNAME_get(sv);
0eb335df 1996 if (hvname) {
6f3289f0
DM
1997 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1998 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
0eb335df
BF
1999 generic_pv_escape( tmpsv, hvname,
2000 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2001 }
bfcb3514 2002 }
86f55936 2003 if (SvOOK(sv)) {
ad64d0ec 2004 AV * const backrefs
85fbaab2 2005 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 2006 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC
2007 if (HvAUX(sv)->xhv_name_count)
2008 Perl_dump_indent(aTHX_
147e3846 2009 level, file, " NAMECOUNT = %" IVdf "\n",
7afc2217 2010 (IV)HvAUX(sv)->xhv_name_count
67e04715 2011 );
15d9236d 2012 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC
2013 const I32 count = HvAUX(sv)->xhv_name_count;
2014 if (count) {
2015 SV * const names = newSVpvs_flags("", SVs_TEMP);
2016 /* The starting point is the first element if count is
2017 positive and the second element if count is negative. */
2018 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2019 + (count < 0 ? 1 : 0);
2020 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2021 + (count < 0 ? -count : count);
2022 while (hekp < endp) {
8e5993c4 2023 if (*hekp) {
6f3289f0 2024 SV *tmp = newSVpvs_flags("", SVs_TEMP);
0eb335df
BF
2025 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2026 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
ec3405c8
NC
2027 } else {
2028 /* This should never happen. */
2029 sv_catpvs(names, ", (null)");
67e04715 2030 }
ec3405c8
NC
2031 ++hekp;
2032 }
67e04715
FC
2033 Perl_dump_indent(aTHX_
2034 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2035 );
2036 }
0eb335df
BF
2037 else {
2038 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2039 const char *const hvename = HvENAME_get(sv);
67e04715 2040 Perl_dump_indent(aTHX_
0eb335df
BF
2041 level, file, " ENAME = \"%s\"\n",
2042 generic_pv_escape(tmp, hvename,
2043 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2044 }
67e04715 2045 }
86f55936 2046 if (backrefs) {
147e3846 2047 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
86f55936 2048 PTR2UV(backrefs));
ad64d0ec 2049 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC
2050 dumpops, pvlim);
2051 }
7d88e6c4 2052 if (meta) {
0eb335df 2053 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
147e3846
KW
2054 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2055 UVxf ")\n",
0eb335df
BF
2056 generic_pv_escape( tmpsv, meta->mro_which->name,
2057 meta->mro_which->length,
2058 (meta->mro_which->kflags & HVhek_UTF8)),
7d88e6c4 2059 PTR2UV(meta->mro_which));
147e3846
KW
2060 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2061 UVxf "\n",
7d88e6c4 2062 (UV)meta->cache_gen);
147e3846 2063 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
7d88e6c4
NC
2064 (UV)meta->pkg_gen);
2065 if (meta->mro_linear_all) {
147e3846
KW
2066 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2067 UVxf "\n",
7d88e6c4
NC
2068 PTR2UV(meta->mro_linear_all));
2069 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2070 dumpops, pvlim);
2071 }
2072 if (meta->mro_linear_current) {
147e3846
KW
2073 Perl_dump_indent(aTHX_ level, file,
2074 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
7d88e6c4
NC
2075 PTR2UV(meta->mro_linear_current));
2076 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2077 dumpops, pvlim);
2078 }
2079 if (meta->mro_nextmethod) {
147e3846
KW
2080 Perl_dump_indent(aTHX_ level, file,
2081 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
7d88e6c4
NC
2082 PTR2UV(meta->mro_nextmethod));
2083 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2084 dumpops, pvlim);
2085 }
2086 if (meta->isa) {
147e3846 2087 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
7d88e6c4
NC
2088 PTR2UV(meta->isa));
2089 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2090 dumpops, pvlim);
2091 }
2092 }
86f55936 2093 }
b5698553 2094 if (nest < maxnest) {
cbab3169 2095 HV * const hv = MUTABLE_HV(sv);
b5698553
TH
2096 STRLEN i;
2097 HE *he;
cbab3169 2098
b5698553
TH
2099 if (HvARRAY(hv)) {
2100 int count = maxnest - nest;
2101 for (i=0; i <= HvMAX(hv); i++) {
2102 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2103 U32 hash;
2104 SV * keysv;
2105 const char * keypv;
2106 SV * elt;
7dc86639 2107 STRLEN len;
b5698553
TH
2108
2109 if (count-- <= 0) goto DONEHV;
2110
2111 hash = HeHASH(he);
2112 keysv = hv_iterkeysv(he);
2113 keypv = SvPV_const(keysv, len);
2114 elt = HeVAL(he);
cbab3169 2115
7dc86639
YO
2116 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2117 if (SvUTF8(keysv))
2118 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH
2119 if (HvEITER_get(hv) == he)
2120 PerlIO_printf(file, "[CURRENT] ");
147e3846 2121 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
7dc86639
YO
2122 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2123 }
b5698553
TH
2124 }
2125 DONEHV:;
2126 }
3967c732
JD
2127 }
2128 break;
5d27ee4a 2129 } /* case SVt_PVHV */
e0bbf362 2130
3967c732 2131 case SVt_PVCV:
8fa6a409 2132 if (CvAUTOLOAD(sv)) {
0eb335df 2133 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
6f3289f0 2134 STRLEN len;
8fa6a409 2135 const char *const name = SvPV_const(sv, len);
0eb335df
BF
2136 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2137 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
8fa6a409
FC
2138 }
2139 if (SvPOK(sv)) {
6f3289f0
DM
2140 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2141 const char *const proto = CvPROTO(sv);
0eb335df
BF
2142 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2143 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2144 SvUTF8(sv)));
cbf82dd0 2145 }
924ba076 2146 /* FALLTHROUGH */
3967c732
JD
2147 case SVt_PVFM:
2148 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC
2149 if (!CvISXSUB(sv)) {
2150 if (CvSTART(sv)) {
27604593
DM
2151 if (CvSLABBED(sv))
2152 Perl_dump_indent(aTHX_ level, file,
147e3846 2153 " SLAB = 0x%" UVxf "\n",
27604593
DM
2154 PTR2UV(CvSTART(sv)));
2155 else
2156 Perl_dump_indent(aTHX_ level, file,
147e3846 2157 " START = 0x%" UVxf " ===> %" IVdf "\n",
d04ba589
NC
2158 PTR2UV(CvSTART(sv)),
2159 (IV)sequence_num(CvSTART(sv)));
2160 }
147e3846 2161 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
d04ba589
NC
2162 PTR2UV(CvROOT(sv)));
2163 if (CvROOT(sv) && dumpops) {
2164 do_op_dump(level+1, file, CvROOT(sv));
2165 }
2166 } else {
126f53f3 2167 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 2168
147e3846 2169 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
b1886099
NC
2170
2171 if (constant) {
147e3846 2172 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
b1886099
NC
2173 " (CONST SV)\n",
2174 PTR2UV(CvXSUBANY(sv).any_ptr));
2175 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2176 pvlim);
2177 } else {
147e3846 2178 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
b1886099
NC
2179 (IV)CvXSUBANY(sv).any_i32);
2180 }
2181 }
3610c89f
FC
2182 if (CvNAMED(sv))
2183 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2184 HEK_KEY(CvNAME_HEK((CV *)sv)));
2185 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 2186 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
147e3846
KW
2187 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2188 IVdf "\n", (IV)CvDEPTH(sv));
2189 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2190 (UV)CvFLAGS(sv));
2191 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
eacbb379 2192 if (!CvISXSUB(sv)) {
147e3846 2193 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
eacbb379
DD
2194 if (nest < maxnest) {
2195 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2196 }
3967c732 2197 }
eacbb379 2198 else
db6e00bd 2199 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
3967c732 2200 {
b9ac451d 2201 const CV * const outside = CvOUTSIDE(sv);
147e3846 2202 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
57def98f 2203 PTR2UV(outside),
cf2093f6
JH
2204 (!outside ? "null"
2205 : CvANON(outside) ? "ANON"
2206 : (outside == PL_main_cv) ? "MAIN"
2207 : CvUNIQUE(outside) ? "UNIQUE"
b24fda9d
BF
2208 : CvGV(outside) ?
2209 generic_pv_escape(
2210 newSVpvs_flags("", SVs_TEMP),
2211 GvNAME(CvGV(outside)),
2212 GvNAMELEN(CvGV(outside)),
2213 GvNAMEUTF8(CvGV(outside)))
2214 : "UNDEFINED"));
3967c732 2215 }
704b97aa
FC
2216 if (CvOUTSIDE(sv)
2217 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
ad64d0ec 2218 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2219 break;
e0bbf362 2220
926fc7b6
DM
2221 case SVt_PVGV:
2222 case SVt_PVLV:
b9ac451d
AL
2223 if (type == SVt_PVLV) {
2224 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
147e3846
KW
2225 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2226 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2227 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2228 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
305b8651 2229 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
b9ac451d
AL
2230 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2231 dumpops, pvlim);
2232 }
8d919b0a 2233 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM
2234 if (!isGV_with_GP(sv))
2235 break;
6f3289f0
DM
2236 {
2237 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2238 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2239 generic_pv_escape(tmpsv, GvNAME(sv),
2240 GvNAMELEN(sv),
2241 GvNAMEUTF8(sv)));
2242 }
147e3846 2243 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
3967c732 2244 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
147e3846
KW
2245 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2246 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
f472eb5c
GS
2247 if (!GvGP(sv))
2248 break;
147e3846
KW
2249 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2250 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2251 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2252 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2253 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2254 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2255 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2256 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2257 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
008009b0
FC
2258 " (%s)\n",
2259 (UV)GvGPFLAGS(sv),
71afaece 2260 "");
147e3846 2261 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
b195d487 2262 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
3967c732
JD
2263 do_gv_dump (level, file, " EGV", GvEGV(sv));
2264 break;
2265 case SVt_PVIO:
147e3846
KW
2266 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2267 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2268 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2269 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2270 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2271 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2272 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
27533608 2273 if (IoTOP_NAME(sv))
cea2e8a9 2274 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC
2275 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2276 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2277 else {
147e3846 2278 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
9ba1f565 2279 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC
2280 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2281 maxnest, dumpops, pvlim);
9ba1f565
NC
2282 }
2283 /* Source filters hide things that are not GVs in these three, so let's
2284 be careful out there. */
27533608 2285 if (IoFMT_NAME(sv))
cea2e8a9 2286 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC
2287 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2288 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2289 else {
147e3846 2290 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
9ba1f565 2291 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC
2292 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2293 maxnest, dumpops, pvlim);
9ba1f565 2294 }
27533608 2295 if (IoBOTTOM_NAME(sv))
cea2e8a9 2296 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC
2297 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2298 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2299 else {
147e3846 2300 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
9ba1f565 2301 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC
2302 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2303 maxnest, dumpops, pvlim);
9ba1f565 2304 }
27533608 2305 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2306 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2307 else
cea2e8a9 2308 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
147e3846 2309 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
3967c732 2310 break;
206ee256 2311 case SVt_REGEXP:
8d919b0a 2312 dumpregexp:
d63e6659 2313 {
8d919b0a 2314 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO
2315
2316#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2317 sv_setpv(d,""); \
e3e400ec 2318 append_flags(d, flags, names); \
ec16d31f
YO
2319 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2320 SvCUR_set(d, SvCUR(d) - 1); \
2321 SvPVX(d)[SvCUR(d)] = '\0'; \
2322 } \
2323} STMT_END
e3e400ec 2324 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
147e3846 2325 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO
2326 (UV)(r->compflags), SvPVX_const(d));
2327
e3e400ec 2328 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
147e3846 2329 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO
2330 (UV)(r->extflags), SvPVX_const(d));
2331
147e3846 2332 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
e3e400ec
YO
2333 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2334 if (r->engine == &PL_core_reg_engine) {
2335 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
147e3846 2336 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
e3e400ec
YO
2337 (UV)(r->intflags), SvPVX_const(d));
2338 } else {
147e3846 2339 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
d63e6659 2340 (UV)(r->intflags));
e3e400ec
YO
2341 }
2342#undef SV_SET_STRINGIFY_REGEXP_FLAGS
147e3846 2343 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
d63e6659 2344 (UV)(r->nparens));
147e3846 2345 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
d63e6659 2346 (UV)(r->lastparen));
147e3846 2347 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
d63e6659 2348 (UV)(r->lastcloseparen));
147e3846 2349 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
d63e6659 2350 (IV)(r->minlen));
147e3846 2351 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
d63e6659 2352 (IV)(r->minlenret));
147e3846 2353 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
d63e6659 2354 (UV)(r->gofs));
147e3846 2355 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
d63e6659 2356 (UV)(r->pre_prefix));
147e3846 2357 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
d63e6659 2358 (IV)(r->sublen));
147e3846 2359 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
6502e081 2360 (IV)(r->suboffset));
147e3846 2361 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
6502e081 2362 (IV)(r->subcoffset));
d63e6659 2363 if (r->subbeg)
147e3846 2364 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
d63e6659
DM
2365 PTR2UV(r->subbeg),
2366 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2367 else
2368 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
147e3846 2369 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
d63e6659 2370 PTR2UV(r->mother_re));
01ffd0f1
FC
2371 if (nest < maxnest && r->mother_re)
2372 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2373 maxnest, dumpops, pvlim);
147e3846 2374 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
d63e6659 2375 PTR2UV(r->paren_names));
147e3846 2376 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
d63e6659 2377 PTR2UV(r->substrs));
147e3846 2378 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
d63e6659 2379 PTR2UV(r->pprivate));
147e3846 2380 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
d63e6659 2381 PTR2UV(r->offs));
147e3846 2382 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
d63c20f2 2383 PTR2UV(r->qr_anoncv));
db2c6cb3 2384#ifdef PERL_ANY_COW
147e3846 2385 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
d63e6659
DM
2386 PTR2UV(r->saved_copy));
2387#endif
2388 }
206ee256 2389 break;
3967c732 2390 }
5f954473 2391 SvREFCNT_dec_NN(d);
3967c732
JD
2392}
2393
36b1c95c
MH
2394/*
2395=for apidoc sv_dump
2396
2397Dumps the contents of an SV to the C<STDERR> filehandle.
2398
2399For an example of its output, see L<Devel::Peek>.
2400
2401=cut
2402*/
2403
3967c732 2404void
864dbfa3 2405Perl_sv_dump(pTHX_ SV *sv)
3967c732 2406{
769b28f4 2407 if (sv && SvROK(sv))
d1029faa
JP
2408 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2409 else
2410 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2411}
bd16a5f0
IZ
2412
2413int
2414Perl_runops_debug(pTHX)
2415{
87058c31
DM
2416#ifdef DEBUGGING && !defined DEBUGGING_RE_ONLY
2417 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2418
2419 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2420#endif
2421
bd16a5f0 2422 if (!PL_op) {
9b387841 2423 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ
2424 return 0;
2425 }
9f3673fb 2426 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2427 do {
75d476e2
SM
2428#ifdef PERL_TRACE_OPS
2429 ++PL_op_exec_cnt[PL_op->op_type];
2430#endif
87058c31
DM
2431#ifdef DEBUGGING && !defined DEBUGGING_RE_ONLY
2432 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2433 Perl_croak_nocontext(
2434 "panic: previous op failed to extend arg stack: "
2435 "base=%p, sp=%p, hwm=%p\n",
2436 PL_stack_base, PL_stack_sp,
2437 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2438 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2439#endif
bd16a5f0 2440 if (PL_debug) {
991bab54
DM
2441 ENTER;
2442 SAVETMPS;
b9ac451d 2443 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0 2444 PerlIO_printf(Perl_debug_log,
147e3846 2445 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
bd16a5f0
IZ
2446 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2447 PTR2UV(*PL_watchaddr));
d6721266
DM
2448 if (DEBUG_s_TEST_) {
2449 if (DEBUG_v_TEST_) {
2450 PerlIO_printf(Perl_debug_log, "\n");
2451 deb_stack_all();
2452 }
2453 else
2454 debstack();
2455 }
2456
2457
bd16a5f0
IZ
2458 if (DEBUG_t_TEST_) debop(PL_op);
2459 if (DEBUG_P_TEST_) debprof(PL_op);
991bab54
DM
2460 FREETMPS;
2461 LEAVE;
bd16a5f0 2462 }
fe83c362 2463
3f6bd23a 2464 PERL_DTRACE_PROBE_OP(PL_op);
16c91539 2465 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2466 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2467 PERL_ASYNC_CHECK();
bd16a5f0 2468
87058c31
DM
2469#ifdef DEBUGGING && !defined DEBUGGING_RE_ONLY
2470 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
2471#endif
bd16a5f0
IZ
2472 TAINT_NOT;
2473 return 0;
2474}
2475
f9b02e42
DM
2476
2477/* print the names of the n lexical vars starting at pad offset off */
2478
f9db5646 2479STATIC void
f9b02e42
DM
2480S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2481{
2482 PADNAME *sv;
2483 CV * const cv = deb_curcv(cxstack_ix);
2484 PADNAMELIST *comppad = NULL;
2485 int i;
2486
2487 if (cv) {
2488 PADLIST * const padlist = CvPADLIST(cv);
2489 comppad = PadlistNAMES(padlist);
2490 }
2491 if (paren)
2492 PerlIO_printf(Perl_debug_log, "(");
2493 for (i = 0; i < n; i++) {
2494 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
147e3846 2495 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
f9b02e42 2496 else
147e3846 2497 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
f9b02e42
DM
2498 (UV)(off+i));
2499 if (i < n - 1)
2500 PerlIO_printf(Perl_debug_log, ",");
2501 }
2502 if (paren)
2503 PerlIO_printf(Perl_debug_log, ")");
2504}
2505
2506
fedf30e1
DM
2507/* append to the out SV, the name of the lexical at offset off in the CV
2508 * cv */
2509
ec48399d 2510static void
fedf30e1
DM
2511S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2512 bool paren, bool is_scalar)
2513{
2514 PADNAME *sv;
2515 PADNAMELIST *namepad = NULL;
2516 int i;
2517
2518 if (cv) {
2519 PADLIST * const padlist = CvPADLIST(cv);
2520 namepad = PadlistNAMES(padlist);
2521 }
2522
2523 if (paren)
2524 sv_catpvs_nomg(out, "(");
2525 for (i = 0; i < n; i++) {
2526 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2527 {
2528 STRLEN cur = SvCUR(out);
147e3846 2529 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
26334c4d
FC
2530 UTF8fARG(1, PadnameLEN(sv) - 1,
2531 PadnamePV(sv) + 1));
fedf30e1
DM
2532 if (is_scalar)
2533 SvPVX(out)[cur] = '$';
2534 }
2535 else
147e3846 2536 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
fedf30e1
DM
2537 if (i < n - 1)
2538 sv_catpvs_nomg(out, ",");
2539 }
2540 if (paren)
2541 sv_catpvs_nomg(out, "(");
2542}
2543
2544
ec48399d 2545static void
8bbe2fa8 2546S_append_gv_name(pTHX_ GV *gv, SV *out)
fedf30e1
DM
2547{
2548 SV *sv;
2549 if (!gv) {
2550 sv_catpvs_nomg(out, "<NULLGV>");
2551 return;
2552 }
2553 sv = newSV(0);
2554 gv_fullname4(sv, gv, NULL, FALSE);
147e3846 2555 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
fedf30e1
DM
2556 SvREFCNT_dec_NN(sv);
2557}
2558
2559#ifdef USE_ITHREADS
dc3c1c70
DM
2560# define ITEM_SV(item) (comppad ? \
2561 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
fedf30e1
DM
2562#else
2563# define ITEM_SV(item) UNOP_AUX_item_sv(item)
2564#endif
2565
2566
2567/* return a temporary SV containing a stringified representation of
48ee9c0e 2568 * the op_aux field of a MULTIDEREF op, associated with CV cv
fedf30e1
DM
2569 */
2570
2571SV*
48ee9c0e 2572Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
fedf30e1
DM
2573{
2574 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2575 UV actions = items->uv;
2576 SV *sv;
2577 bool last = 0;
2578 bool is_hash = FALSE;
2579 int derefs = 0;
ff94d24c 2580 SV *out = newSVpvn_flags("",0,SVs_TEMP);
fedf30e1 2581#ifdef USE_ITHREADS
dc3c1c70
DM
2582 PAD *comppad;
2583
2584 if (cv) {
2585 PADLIST *padlist = CvPADLIST(cv);
2586 comppad = PadlistARRAY(padlist)[1];
2587 }
2588 else
2589 comppad = NULL;
fedf30e1
DM
2590#endif
2591
48ee9c0e 2592 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
fedf30e1
DM
2593
2594 while (!last) {
2595 switch (actions & MDEREF_ACTION_MASK) {
2596
2597 case MDEREF_reload:
2598 actions = (++items)->uv;
2599 continue;
2b5060ae 2600 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2601
2602 case MDEREF_HV_padhv_helem:
2603 is_hash = TRUE;
2b5060ae 2604 /* FALLTHROUGH */
fedf30e1
DM
2605 case MDEREF_AV_padav_aelem:
2606 derefs = 1;
2607 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2608 goto do_elem;
2b5060ae 2609 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2610
2611 case MDEREF_HV_gvhv_helem:
2612 is_hash = TRUE;
2b5060ae 2613 /* FALLTHROUGH */
fedf30e1
DM
2614 case MDEREF_AV_gvav_aelem:
2615 derefs = 1;
dc3c1c70
DM
2616 items++;
2617 sv = ITEM_SV(items);
8bbe2fa8 2618 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2619 goto do_elem;
2b5060ae 2620 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2621
2622 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2623 is_hash = TRUE;
2b5060ae 2624 /* FALLTHROUGH */
fedf30e1 2625 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
dc3c1c70
DM
2626 items++;
2627 sv = ITEM_SV(items);
8bbe2fa8 2628 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2629 goto do_vivify_rv2xv_elem;
2b5060ae 2630 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2631
2632 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2633 is_hash = TRUE;
2b5060ae 2634 /* FALLTHROUGH */
fedf30e1
DM
2635 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2636 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2637 goto do_vivify_rv2xv_elem;
2b5060ae 2638 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM
2639
2640 case MDEREF_HV_pop_rv2hv_helem:
2641 case MDEREF_HV_vivify_rv2hv_helem:
2642 is_hash = TRUE;
2b5060ae 2643 /* FALLTHROUGH */
fedf30e1
DM
2644 do_vivify_rv2xv_elem:
2645 case MDEREF_AV_pop_rv2av_aelem:
2646 case MDEREF_AV_vivify_rv2av_aelem:
2647 if (!derefs++)
2648 sv_catpvs_nomg(out, "->");
2649 do_elem:
2650 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2651 sv_catpvs_nomg(out, "->");
2652 last = 1;
2653 break;
2654 }
2655
2656 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2657 switch (actions & MDEREF_INDEX_MASK) {
2658 case MDEREF_INDEX_const:
2659 if (is_hash) {
dc3c1c70
DM
2660 items++;
2661 sv = ITEM_SV(items);
2662 if (!sv)
2663 sv_catpvs_nomg(out, "???");
2664 else {
2665 STRLEN cur;
2666 char *s;
2667 s = SvPV(sv, cur);
2668 pv_pretty(out, s, cur, 30,
2669 NULL, NULL,
2670 (PERL_PV_PRETTY_NOCLEAR
2671 |PERL_PV_PRETTY_QUOTE
2672 |PERL_PV_PRETTY_ELLIPSES));
2673 }
fedf30e1
DM
2674 }
2675 else
147e3846 2676 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
fedf30e1
DM
2677 break;
2678 case MDEREF_INDEX_padsv:
2679 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2680 break;
2681 case MDEREF_INDEX_gvsv:
dc3c1c70
DM
2682 items++;
2683 sv = ITEM_SV(items);
8bbe2fa8 2684 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM
2685 break;
2686 }
2687 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2688
2689 if (actions & MDEREF_FLAG_last)
2690 last = 1;
2691 is_hash = FALSE;
2692
2693 break;
2694
2695 default:
2696 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2697 (int)(actions & MDEREF_ACTION_MASK));
2698 last = 1;
2699 break;
2700
2701 } /* switch */
2702
2703 actions >>= MDEREF_SHIFT;
2704 } /* while */
2705 return out;
2706}
2707
2708
bd16a5f0 2709I32
6867be6d 2710Perl_debop(pTHX_ const OP *o)
bd16a5f0 2711{
7918f24d
NC
2712 PERL_ARGS_ASSERT_DEBOP;
2713
1045810a
IZ
2714 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2715 return 0;
2716
bd16a5f0
IZ
2717 Perl_deb(aTHX_ "%s", OP_NAME(o));
2718 switch (o->op_type) {
2719 case OP_CONST:
996c9baa 2720 case OP_HINTSEVAL:
6cefa69e 2721 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2722 * may not be active here, so check.
6cefa69e 2723 * Looks like only during compiling the pads are illegal.
7367e658 2724 */
6cefa69e
RU
2725#ifdef USE_ITHREADS
2726 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2727#endif
7367e658 2728 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ
2729 break;
2730 case OP_GVSV:
2731 case OP_GV:
e18c4116
DM
2732 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2733 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
bd16a5f0 2734 break;
a7fd8ef6 2735
bd16a5f0
IZ
2736 case OP_PADSV:
2737 case OP_PADAV:
2738 case OP_PADHV:
4fa06845 2739 case OP_ARGELEM:
f9b02e42
DM
2740 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2741 break;
fedf30e1 2742
a7fd8ef6 2743 case OP_PADRANGE:
f9b02e42
DM
2744 S_deb_padvar(aTHX_ o->op_targ,
2745 o->op_private & OPpPADRANGE_COUNTMASK, 1);
bd16a5f0 2746 break;
a7fd8ef6 2747
fedf30e1 2748 case OP_MULTIDEREF:
147e3846 2749 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
ac892e4a 2750 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
fedf30e1
DM
2751 break;
2752
bd16a5f0 2753 default:
091ab601 2754 break;
bd16a5f0
IZ
2755 }
2756 PerlIO_printf(Perl_debug_log, "\n");
2757 return 0;
2758}
2759
1e85b658
DM
2760
2761/*
2762=for apidoc op_class
2763
2764Given an op, determine what type of struct it has been allocated as.
2765Returns one of the OPclass enums, such as OPclass_LISTOP.
2766
2767=cut
2768*/
2769
2770
2771OPclass
2772Perl_op_class(pTHX_ const OP *o)
2773{
2774 bool custom = 0;
2775
2776 if (!o)
2777 return OPclass_NULL;
2778
2779 if (o->op_type == 0) {
2780 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2781 return OPclass_COP;
2782 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2783 }
2784
2785 if (o->op_type == OP_SASSIGN)
2786 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2787
2788 if (o->op_type == OP_AELEMFAST) {
2789#ifdef USE_ITHREADS
2790 return OPclass_PADOP;
2791#else
2792 return OPclass_SVOP;
2793#endif
2794 }
2795
2796#ifdef USE_ITHREADS
2797 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2798 o->op_type == OP_RCATLINE)
2799 return OPclass_PADOP;
2800#endif
2801
2802 if (o->op_type == OP_CUSTOM)
2803 custom = 1;
2804
2805 switch (OP_CLASS(o)) {
2806 case OA_BASEOP:
2807 return OPclass_BASEOP;
2808
2809 case OA_UNOP:
2810 return OPclass_UNOP;
2811
2812 case OA_BINOP:
2813 return OPclass_BINOP;
2814
2815 case OA_LOGOP:
2816 return OPclass_LOGOP;
2817
2818 case OA_LISTOP:
2819 return OPclass_LISTOP;
2820
2821 case OA_PMOP:
2822 return OPclass_PMOP;
2823
2824 case OA_SVOP:
2825 return OPclass_SVOP;
2826
2827 case OA_PADOP:
2828 return OPclass_PADOP;
2829
2830 case OA_PVOP_OR_SVOP:
2831 /*
2832 * Character translations (tr///) are usually a PVOP, keeping a
2833 * pointer to a table of shorts used to look up translations.
2834 * Under utf8, however, a simple table isn't practical; instead,
2835 * the OP is an SVOP (or, under threads, a PADOP),
2836 * and the SV is a reference to a swash
2837 * (i.e., an RV pointing to an HV).
2838 */
2839 return (!custom &&
2840 (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2841 )
2842#if defined(USE_ITHREADS)
2843 ? OPclass_PADOP : OPclass_PVOP;
2844#else
2845 ? OPclass_SVOP : OPclass_PVOP;
2846#endif
2847
2848 case OA_LOOP:
2849 return OPclass_LOOP;
2850
2851 case OA_COP:
2852 return OPclass_COP;
2853
2854 case OA_BASEOP_OR_UNOP:
2855 /*
2856 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2857 * whether parens were seen. perly.y uses OPf_SPECIAL to
2858 * signal whether a BASEOP had empty parens or none.
2859 * Some other UNOPs are created later, though, so the best
2860 * test is OPf_KIDS, which is set in newUNOP.
2861 */
2862 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2863
2864 case OA_FILESTATOP:
2865 /*
2866 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2867 * the OPf_REF flag to distinguish between OP types instead of the
2868 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2869 * return OPclass_UNOP so that walkoptree can find our children. If
2870 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2871 * (no argument to the operator) it's an OP; with OPf_REF set it's
2872 * an SVOP (and op_sv is the GV for the filehandle argument).
2873 */
2874 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2875#ifdef USE_ITHREADS
2876 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2877#else
2878 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
2879#endif
2880 case OA_LOOPEXOP:
2881 /*
2882 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
2883 * label was omitted (in which case it's a BASEOP) or else a term was
2884 * seen. In this last case, all except goto are definitely PVOP but
2885 * goto is either a PVOP (with an ordinary constant label), an UNOP
2886 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
2887 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
2888 * get set.
2889 */
2890 if (o->op_flags & OPf_STACKED)
2891 return OPclass_UNOP;
2892 else if (o->op_flags & OPf_SPECIAL)
2893 return OPclass_BASEOP;
2894 else
2895 return OPclass_PVOP;
2896 case OA_METHOP:
2897 return OPclass_METHOP;
2898 case OA_UNOP_AUX:
2899 return OPclass_UNOP_AUX;
2900 }
2901 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
2902 OP_NAME(o));
2903 return OPclass_BASEOP;
2904}
2905
2906
2907
bd16a5f0 2908STATIC CV*
dc6240c9 2909S_deb_curcv(pTHX_ I32 ix)
bd16a5f0 2910{
dc6240c9
DM
2911 PERL_SI *si = PL_curstackinfo;
2912 for (; ix >=0; ix--) {
2913 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2914
2915 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2916 return cx->blk_sub.cv;
2917 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2918 return cx->blk_eval.cv;
2919 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2920 return PL_main_cv;
2921 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2922 && si->si_type == PERLSI_SORT)
2923 {
2924 /* fake sort sub; use CV of caller */
2925 si = si->si_prev;
2926 ix = si->si_cxix + 1;
2927 }
2928 }
2929 return NULL;
bd16a5f0
IZ
2930}
2931
2932void
2933Perl_watch(pTHX_ char **addr)
2934{
7918f24d
NC
2935 PERL_ARGS_ASSERT_WATCH;
2936
bd16a5f0
IZ
2937 PL_watchaddr = addr;
2938 PL_watchok = *addr;
147e3846 2939 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
bd16a5f0
IZ
2940 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2941}
2942
2943STATIC void
e1ec3a88 2944S_debprof(pTHX_ const OP *o)
bd16a5f0 2945{
7918f24d
NC
2946 PERL_ARGS_ASSERT_DEBPROF;
2947
61f9802b 2948 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2949 return;
bd16a5f0 2950 if (!PL_profiledata)
a02a5408 2951 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ
2952 ++PL_profiledata[o->op_type];
2953}
2954
2955void
2956Perl_debprofdump(pTHX)
2957{
2958 unsigned i;
2959 if (!PL_profiledata)
2960 return;
2961 for (i = 0; i < MAXO; i++) {
2962 if (PL_profiledata[i])
2963 PerlIO_printf(Perl_debug_log,
2964 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2965 PL_op_name[i]);
2966 }
2967}
66610fdd 2968
3b721df9 2969
66610fdd 2970/*
14d04a33 2971 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2972 */