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