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