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