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
PATCH: [perl #133756] Failure to match properly
[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{
cea89e20 1702 SV *d;
e1ec3a88 1703 const char *s;
3967c732
JD		 1704 U32 flags;
1705 U32 type;
1706
7918f24d
NC		 1707 PERL_ARGS_ASSERT_DO_SV_DUMP;
1708
3967c732 1709 if (!sv) {
cea2e8a9 1710 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1711 return;
378cc40b 1712 }
2ef28da1 1713
3967c732
JD		 1714 flags = SvFLAGS(sv);
1715 type = SvTYPE(sv);
79072805 1716
e0bbf362
DM		 1717 /* process general SV flags */
1718
cea89e20 1719 d = Perl_newSVpvf(aTHX_
147e3846 1720 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
56431972 1721 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS		 1722 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1723 (int)(PL_dumpindent*level), "");
8d063cd8 1724
0f94cb1f 1725 if ((flags & SVs_PADSTALE))
f8db7d5b 1726 sv_catpvs(d, "PADSTALE,");
0f94cb1f 1727 if ((flags & SVs_PADTMP))
f8db7d5b 1728 sv_catpvs(d, "PADTMP,");
a0c2f4dd 1729 append_flags(d, flags, first_sv_flags_names);
810b8aa5 1730 if (flags & SVf_ROK) {
d3425164 1731 sv_catpvs(d, "ROK,");
f8db7d5b 1732 if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,");
810b8aa5 1733 }
45eaf8af 1734 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
a0c2f4dd 1735 append_flags(d, flags, second_sv_flags_names);
7db6405c
FC		 1736 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1737 && type != SVt_PVAV) {
1ccdb730 1738 if (SvPCS_IMPORTED(sv))
f8db7d5b 1739 sv_catpvs(d, "PCS_IMPORTED,");
1ccdb730 1740 else
f8db7d5b 1741 sv_catpvs(d, "SCREAM,");
1ccdb730 1742 }
3967c732 1743
e0bbf362
DM		 1744 /* process type-specific SV flags */
1745
3967c732
JD		 1746 switch (type) {
1747 case SVt_PVCV:
1748 case SVt_PVFM:
ae1f06a1 1749 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD		 1750 break;
1751 case SVt_PVHV:
ae1f06a1 1752 append_flags(d, flags, hv_flags_names);
3967c732 1753 break;
926fc7b6
DM		 1754 case SVt_PVGV:
1755 case SVt_PVLV:
1756 if (isGV_with_GP(sv)) {
ae1f06a1 1757 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1758 }
926fc7b6 1759 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
f8db7d5b 1760 sv_catpvs(d, "IMPORT");
3967c732 1761 if (GvIMPORTED(sv) == GVf_IMPORTED)
f8db7d5b 1762 sv_catpvs(d, "ALL,");
3967c732 1763 else {
f8db7d5b 1764 sv_catpvs(d, "(");
ae1f06a1 1765 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
f8db7d5b 1766 sv_catpvs(d, " ),");
3967c732
JD		 1767 }
1768 }
924ba076 1769 /* FALLTHROUGH */
a5c7cb08 1770 case SVt_PVMG:
25da4f38 1771 default:
f8db7d5b 1772 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,");
25da4f38 1773 break;
a5c7cb08 1774
11ca45c0
NC		 1775 case SVt_PVAV:
1776 break;
3967c732 1777 }
86f0d186
NC		 1778 /* SVphv_SHAREKEYS is also 0x20000000 */
1779 if ((type != SVt_PVHV) && SvUTF8(sv))
f8db7d5b 1780 sv_catpvs(d, "UTF8");
3967c732 1781
b162af07
SP		 1782 if (*(SvEND(d) - 1) == ',') {
1783 SvCUR_set(d, SvCUR(d) - 1);
1784 SvPVX(d)[SvCUR(d)] = '\0';
1785 }
f8db7d5b 1786 sv_catpvs(d, ")");
b15aece3 1787 s = SvPVX_const(d);
3967c732 1788
e0bbf362
DM		 1789 /* dump initial SV details */
1790
fd0854ff 1791#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1792 Perl_dump_indent(aTHX_ level, file,
147e3846 1793 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
fd0854ff
DM		 1794 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1795 sv->sv_debug_line,
1796 sv->sv_debug_inpad ? "for" : "by",
1797 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1798 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM		 1799 sv->sv_debug_serial
1800 );
fd0854ff 1801#endif
cea2e8a9 1802 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM		 1803
1804 /* Dump SV type */
1805
5357ca29
NC		 1806 if (type < SVt_LAST) {
1807 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1808
1809 if (type == SVt_NULL) {
5f954473 1810 SvREFCNT_dec_NN(d);
5357ca29
NC		 1811 return;
1812 }
1813 } else {
147e3846 1814 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
5f954473 1815 SvREFCNT_dec_NN(d);
3967c732
JD		 1816 return;
1817 }
e0bbf362
DM		 1818
1819 /* Dump general SV fields */
1820
27bd069f 1821 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC		 1822 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1823 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1824 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1825 if (SvIsUV(sv)
765f542d 1826 )
147e3846 1827 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
cf2093f6 1828 else
147e3846 1829 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
38d7fd8b 1830 (void)PerlIO_putc(file, '\n');
3967c732 1831 }
e0bbf362 1832
0f94cb1f 1833 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1834 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1835 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1836 || type == SVt_NV) {
688523a0
KW		 1837 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
1838 STORE_LC_NUMERIC_SET_STANDARD();
88cb8500 1839 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
688523a0 1840 RESTORE_LC_NUMERIC();
3967c732 1841 }
e0bbf362 1842
3967c732 1843 if (SvROK(sv)) {
147e3846
KW		 1844 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1845 PTR2UV(SvRV(sv)));
3967c732
JD		 1846 if (nest < maxnest)
1847 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1848 }
e0bbf362 1849
cea89e20 1850 if (type < SVt_PV) {
5f954473 1851 SvREFCNT_dec_NN(d);
3967c732 1852 return;
cea89e20 1853 }
e0bbf362 1854
5a3c7349
FC		 1855 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1856 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
8d919b0a
FC		 1857 const bool re = isREGEXP(sv);
1858 const char * const ptr =
1859 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1860 if (ptr) {
69240efd 1861 STRLEN delta;
7a4bba22 1862 if (SvOOK(sv)) {
69240efd 1863 SvOOK_offset(sv, delta);
147e3846 1864 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
5186cc12 1865 (UV) delta);
69240efd
NC		 1866 } else {
1867 delta = 0;
7a4bba22 1868 }
147e3846
KW		 1869 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1870 PTR2UV(ptr));
7a4bba22
NC		 1871 if (SvOOK(sv)) {
1872 PerlIO_printf(file, "( %s . ) ",
8d919b0a 1873 pv_display(d, ptr - delta, delta, 0,
7a4bba22
NC		 1874 pvlim));
1875 }
ad3f05ad
KW		 1876 if (type == SVt_INVLIST) {
1877 PerlIO_printf(file, "\n");
1878 /* 4 blanks indents 2 beyond the PV, etc */
1879 _invlist_dump(file, level, " ", sv);
1880 }
1881 else {
685bfc3c
KW		 1882 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1883 re ? 0 : SvLEN(sv),
1884 pvlim));
1885 if (SvUTF8(sv)) /* the 6? \x{....} */
1886 PerlIO_printf(file, " [UTF8 \"%s\"]",
1887 sv_uni_display(d, sv, 6 * SvCUR(sv),
1888 UNI_DISPLAY_QQ));
1889 PerlIO_printf(file, "\n");
ad3f05ad 1890 }
147e3846 1891 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
89042fa4 1892 if (re && type == SVt_PVLV)
5956eec7 1893 /* LV-as-REGEXP usurps len field to store pointer to
89042fa4
DM		 1894 * regexp struct */
1895 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n",
1896 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
1897 else
147e3846 1898 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
8d919b0a 1899 (IV)SvLEN(sv));
93c10d60 1900#ifdef PERL_COPY_ON_WRITE
db2c6cb3
FC		 1901 if (SvIsCOW(sv) && SvLEN(sv))
1902 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1903 CowREFCNT(sv));
1904#endif
3967c732
JD		 1905 }
1906 else
cea2e8a9 1907 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1908 }
e0bbf362 1909
3967c732 1910 if (type >= SVt_PVMG) {
0f94cb1f 1911 if (SvMAGIC(sv))
8530ff28 1912 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
3967c732
JD		 1913 if (SvSTASH(sv))
1914 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC		 1915
1916 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
147e3846
KW		 1917 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1918 (IV)BmUSEFUL(sv));
c13a5c80 1919 }
3967c732 1920 }
e0bbf362
DM		 1921
1922 /* Dump type-specific SV fields */
1923
3967c732 1924 switch (type) {
3967c732 1925 case SVt_PVAV:
147e3846
KW		 1926 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1927 PTR2UV(AvARRAY(sv)));
3967c732 1928 if (AvARRAY(sv) != AvALLOC(sv)) {
147e3846
KW		 1929 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1930 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1931 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1932 PTR2UV(AvALLOC(sv)));
3967c732
JD		 1933 }
1934 else
38d7fd8b 1935 (void)PerlIO_putc(file, '\n');
147e3846
KW		 1936 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1937 (IV)AvFILLp(sv));
1938 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1939 (IV)AvMAX(sv));
ed0faf2e 1940 SvPVCLEAR(d);
f8db7d5b
KW		 1941 if (AvREAL(sv)) sv_catpvs(d, ",REAL");
1942 if (AvREIFY(sv)) sv_catpvs(d, ",REIFY");
b15aece3
SP		 1943 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1944 SvCUR(d) ? SvPVX_const(d) + 1 : "");
476fafda 1945 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
c70927a6 1946 SSize_t count;
476fafda
DM		 1947 SV **svp = AvARRAY(MUTABLE_AV(sv));
1948 for (count = 0;
1949 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1950 count++, svp++)
1951 {
1952 SV* const elt = *svp;
147e3846
KW		 1953 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1954 (IV)count);
476fafda 1955 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
3967c732
JD		 1956 }
1957 }
1958 break;
5d27ee4a
DD		 1959 case SVt_PVHV: {
1960 U32 usedkeys;
0c22a733
DM		 1961 if (SvOOK(sv)) {
1962 struct xpvhv_aux *const aux = HvAUX(sv);
147e3846 1963 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
0c22a733
DM		 1964 (UV)aux->xhv_aux_flags);
1965 }
147e3846 1966 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1186f821 1967 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
5d27ee4a 1968 if (HvARRAY(sv) && usedkeys) {
3967c732
JD		 1969 /* Show distribution of HEs in the ARRAY */
1970 int freq[200];
c3caa5c3 1971#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
3967c732
JD		 1972 int i;
1973 int max = 0;
5d27ee4a 1974 U32 pow2 = 2, keys = usedkeys;
65202027 1975 NV theoret, sum = 0;
3967c732
JD		 1976
1977 PerlIO_printf(file, " (");
1978 Zero(freq, FREQ_MAX + 1, int);
eb160463 1979 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL		 1980 HE* h;
1981 int count = 0;
3967c732
JD		 1982 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1983 count++;
1984 if (count > FREQ_MAX)
1985 count = FREQ_MAX;
1986 freq[count]++;
1987 if (max < count)
1988 max = count;
1989 }
1990 for (i = 0; i <= max; i++) {
1991 if (freq[i]) {
1992 PerlIO_printf(file, "%d%s:%d", i,
1993 (i == FREQ_MAX) ? "+" : "",
1994 freq[i]);
1995 if (i != max)
1996 PerlIO_printf(file, ", ");
1997 }
1998 }
38d7fd8b 1999 (void)PerlIO_putc(file, ')');
b8fa94d8
MG		 2000 /* The "quality" of a hash is defined as the total number of
2001 comparisons needed to access every element once, relative
2002 to the expected number needed for a random hash.
2003
2004 The total number of comparisons is equal to the sum of
e76cd0fa
AMS		 2005 the squares of the number of entries in each bucket.
2006 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG		 2007 value is
2008 n + n(n-1)/2k
2009 */
2010
3967c732
JD		 2011 for (i = max; i > 0; i--) { /* Precision: count down. */
2012 sum += freq[i] * i * i;
2013 }
155aba94 2014 while ((keys = keys >> 1))
3967c732 2015 pow2 = pow2 << 1;
5d27ee4a 2016 theoret = usedkeys;
b8fa94d8 2017 theoret += theoret * (theoret-1)/pow2;
38d7fd8b 2018 (void)PerlIO_putc(file, '\n');
147e3846
KW		 2019 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
2020 NVff "%%", theoret/sum*100);
3967c732 2021 }
38d7fd8b 2022 (void)PerlIO_putc(file, '\n');
147e3846
KW		 2023 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
2024 (IV)usedkeys);
9faf471a
NC		 2025 {
2026 STRLEN count = 0;
2027 HE **ents = HvARRAY(sv);
2028
2029 if (ents) {
2030 HE *const *const last = ents + HvMAX(sv);
2031 count = last + 1 - ents;
2032
2033 do {
2034 if (!*ents)
2035 --count;
2036 } while (++ents <= last);
2037 }
2038
147e3846 2039 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
8bf4c401 2040 (UV)count);
9faf471a 2041 }
147e3846
KW		 2042 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2043 (IV)HvMAX(sv));
e1a7ec8d 2044 if (SvOOK(sv)) {
147e3846
KW		 2045 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
2046 (IV)HvRITER_get(sv));
2047 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
2048 PTR2UV(HvEITER_get(sv)));
6a5b4183 2049#ifdef PERL_HASH_RANDOMIZE_KEYS
147e3846
KW		 2050 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
2051 (UV)HvRAND_get(sv));
e1a7ec8d 2052 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
147e3846
KW		 2053 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2054 (UV)HvLASTRAND_get(sv));
e1a7ec8d 2055 }
6a5b4183 2056#endif
38d7fd8b 2057 (void)PerlIO_putc(file, '\n');
e1a7ec8d 2058 }
8d2f4536 2059 {
b9ac451d 2060 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536 2061 if (mg && mg->mg_obj) {
147e3846 2062 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
8d2f4536
NC		 2063 }
2064 }
bfcb3514 2065 {
b9ac451d 2066 const char * const hvname = HvNAME_get(sv);
0eb335df 2067 if (hvname) {
6f3289f0
DM		 2068 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2069 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
0eb335df
BF		 2070 generic_pv_escape( tmpsv, hvname,
2071 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2072 }
bfcb3514 2073 }
86f55936 2074 if (SvOOK(sv)) {
ad64d0ec 2075 AV * const backrefs
85fbaab2 2076 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 2077 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC		 2078 if (HvAUX(sv)->xhv_name_count)
2079 Perl_dump_indent(aTHX_
147e3846 2080 level, file, " NAMECOUNT = %" IVdf "\n",
7afc2217 2081 (IV)HvAUX(sv)->xhv_name_count
67e04715 2082 );
15d9236d 2083 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC		 2084 const I32 count = HvAUX(sv)->xhv_name_count;
2085 if (count) {
2086 SV * const names = newSVpvs_flags("", SVs_TEMP);
2087 /* The starting point is the first element if count is
2088 positive and the second element if count is negative. */
2089 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2090 + (count < 0 ? 1 : 0);
2091 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2092 + (count < 0 ? -count : count);
2093 while (hekp < endp) {
8e5993c4 2094 if (*hekp) {
6f3289f0 2095 SV *tmp = newSVpvs_flags("", SVs_TEMP);
0eb335df
BF		 2096 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2097 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
ec3405c8
NC		 2098 } else {
2099 /* This should never happen. */
2100 sv_catpvs(names, ", (null)");
67e04715 2101 }
ec3405c8
NC		 2102 ++hekp;
2103 }
67e04715
FC		 2104 Perl_dump_indent(aTHX_
2105 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2106 );
2107 }
0eb335df
BF		 2108 else {
2109 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2110 const char *const hvename = HvENAME_get(sv);
67e04715 2111 Perl_dump_indent(aTHX_
0eb335df
BF		 2112 level, file, " ENAME = \"%s\"\n",
2113 generic_pv_escape(tmp, hvename,
2114 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2115 }
67e04715 2116 }
86f55936 2117 if (backrefs) {
147e3846 2118 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
86f55936 2119 PTR2UV(backrefs));
ad64d0ec 2120 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC		 2121 dumpops, pvlim);
2122 }
7d88e6c4 2123 if (meta) {
0eb335df 2124 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
147e3846
KW		 2125 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2126 UVxf ")\n",
0eb335df
BF		 2127 generic_pv_escape( tmpsv, meta->mro_which->name,
2128 meta->mro_which->length,
2129 (meta->mro_which->kflags & HVhek_UTF8)),
7d88e6c4 2130 PTR2UV(meta->mro_which));
147e3846
KW		 2131 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2132 UVxf "\n",
7d88e6c4 2133 (UV)meta->cache_gen);
147e3846 2134 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
7d88e6c4
NC		 2135 (UV)meta->pkg_gen);
2136 if (meta->mro_linear_all) {
147e3846
KW		 2137 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2138 UVxf "\n",
7d88e6c4
NC		 2139 PTR2UV(meta->mro_linear_all));
2140 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2141 dumpops, pvlim);
2142 }
2143 if (meta->mro_linear_current) {
147e3846
KW		 2144 Perl_dump_indent(aTHX_ level, file,
2145 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
7d88e6c4
NC		 2146 PTR2UV(meta->mro_linear_current));
2147 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2148 dumpops, pvlim);
2149 }
2150 if (meta->mro_nextmethod) {
147e3846
KW		 2151 Perl_dump_indent(aTHX_ level, file,
2152 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
7d88e6c4
NC		 2153 PTR2UV(meta->mro_nextmethod));
2154 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2155 dumpops, pvlim);
2156 }
2157 if (meta->isa) {
147e3846 2158 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
7d88e6c4
NC		 2159 PTR2UV(meta->isa));
2160 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2161 dumpops, pvlim);
2162 }
2163 }
86f55936 2164 }
b5698553 2165 if (nest < maxnest) {
cbab3169 2166 HV * const hv = MUTABLE_HV(sv);
b5698553
TH		 2167 STRLEN i;
2168 HE *he;
cbab3169 2169
b5698553
TH		 2170 if (HvARRAY(hv)) {
2171 int count = maxnest - nest;
2172 for (i=0; i <= HvMAX(hv); i++) {
2173 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2174 U32 hash;
2175 SV * keysv;
2176 const char * keypv;
2177 SV * elt;
7dc86639 2178 STRLEN len;
b5698553
TH		 2179
2180 if (count-- <= 0) goto DONEHV;
2181
2182 hash = HeHASH(he);
2183 keysv = hv_iterkeysv(he);
2184 keypv = SvPV_const(keysv, len);
2185 elt = HeVAL(he);
cbab3169 2186
7dc86639
YO		 2187 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2188 if (SvUTF8(keysv))
2189 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH		 2190 if (HvEITER_get(hv) == he)
2191 PerlIO_printf(file, "[CURRENT] ");
147e3846 2192 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
7dc86639
YO		 2193 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2194 }
b5698553
TH		 2195 }
2196 DONEHV:;
2197 }
3967c732
JD		 2198 }
2199 break;
5d27ee4a 2200 } /* case SVt_PVHV */
e0bbf362 2201
3967c732 2202 case SVt_PVCV:
8fa6a409 2203 if (CvAUTOLOAD(sv)) {
0eb335df 2204 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
6f3289f0 2205 STRLEN len;
8fa6a409 2206 const char *const name = SvPV_const(sv, len);
0eb335df
BF		 2207 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2208 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
8fa6a409
FC		 2209 }
2210 if (SvPOK(sv)) {
6f3289f0
DM		 2211 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2212 const char *const proto = CvPROTO(sv);
0eb335df
BF		 2213 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2214 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2215 SvUTF8(sv)));
cbf82dd0 2216 }
924ba076 2217 /* FALLTHROUGH */
3967c732
JD		 2218 case SVt_PVFM:
2219 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC		 2220 if (!CvISXSUB(sv)) {
2221 if (CvSTART(sv)) {
27604593
DM		 2222 if (CvSLABBED(sv))
2223 Perl_dump_indent(aTHX_ level, file,
147e3846 2224 " SLAB = 0x%" UVxf "\n",
27604593
DM		 2225 PTR2UV(CvSTART(sv)));
2226 else
2227 Perl_dump_indent(aTHX_ level, file,
147e3846 2228 " START = 0x%" UVxf " ===> %" IVdf "\n",
d04ba589
NC		 2229 PTR2UV(CvSTART(sv)),
2230 (IV)sequence_num(CvSTART(sv)));
2231 }
147e3846 2232 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
d04ba589
NC		 2233 PTR2UV(CvROOT(sv)));
2234 if (CvROOT(sv) && dumpops) {
2235 do_op_dump(level+1, file, CvROOT(sv));
2236 }
2237 } else {
126f53f3 2238 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 2239
147e3846 2240 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
b1886099
NC		 2241
2242 if (constant) {
147e3846 2243 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
b1886099
NC		 2244 " (CONST SV)\n",
2245 PTR2UV(CvXSUBANY(sv).any_ptr));
2246 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2247 pvlim);
2248 } else {
147e3846 2249 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
b1886099
NC		 2250 (IV)CvXSUBANY(sv).any_i32);
2251 }
2252 }
3610c89f
FC		 2253 if (CvNAMED(sv))
2254 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2255 HEK_KEY(CvNAME_HEK((CV *)sv)));
2256 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 2257 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
147e3846
KW		 2258 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2259 IVdf "\n", (IV)CvDEPTH(sv));
2260 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2261 (UV)CvFLAGS(sv));
2262 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
eacbb379 2263 if (!CvISXSUB(sv)) {
147e3846 2264 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
eacbb379
DD		 2265 if (nest < maxnest) {
2266 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2267 }
3967c732 2268 }
eacbb379 2269 else
db6e00bd 2270 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
3967c732 2271 {
b9ac451d 2272 const CV * const outside = CvOUTSIDE(sv);
147e3846 2273 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
57def98f 2274 PTR2UV(outside),
cf2093f6
JH		 2275 (!outside ? "null"
2276 : CvANON(outside) ? "ANON"
2277 : (outside == PL_main_cv) ? "MAIN"
2278 : CvUNIQUE(outside) ? "UNIQUE"
b24fda9d
BF		 2279 : CvGV(outside) ?
2280 generic_pv_escape(
2281 newSVpvs_flags("", SVs_TEMP),
2282 GvNAME(CvGV(outside)),
2283 GvNAMELEN(CvGV(outside)),
2284 GvNAMEUTF8(CvGV(outside)))
2285 : "UNDEFINED"));
3967c732 2286 }
704b97aa
FC		 2287 if (CvOUTSIDE(sv)
2288 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
ad64d0ec 2289 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2290 break;
e0bbf362 2291
926fc7b6
DM		 2292 case SVt_PVGV:
2293 case SVt_PVLV:
b9ac451d
AL		 2294 if (type == SVt_PVLV) {
2295 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
147e3846
KW		 2296 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2297 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2298 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2299 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
305b8651 2300 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
b9ac451d
AL		 2301 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2302 dumpops, pvlim);
2303 }
8d919b0a 2304 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM		 2305 if (!isGV_with_GP(sv))
2306 break;
6f3289f0
DM		 2307 {
2308 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2309 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2310 generic_pv_escape(tmpsv, GvNAME(sv),
2311 GvNAMELEN(sv),
2312 GvNAMEUTF8(sv)));
2313 }
147e3846 2314 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
3967c732 2315 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
147e3846
KW		 2316 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2317 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
f472eb5c
GS		 2318 if (!GvGP(sv))
2319 break;
147e3846
KW		 2320 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2321 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2322 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2323 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2324 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2325 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2326 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2327 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2328 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
008009b0
FC		 2329 " (%s)\n",
2330 (UV)GvGPFLAGS(sv),
71afaece 2331 "");
147e3846 2332 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
b195d487 2333 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
3967c732
JD		 2334 do_gv_dump (level, file, " EGV", GvEGV(sv));
2335 break;
2336 case SVt_PVIO:
147e3846
KW		 2337 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2338 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2339 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2340 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2341 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2342 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2343 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
27533608 2344 if (IoTOP_NAME(sv))
cea2e8a9 2345 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC		 2346 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2347 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2348 else {
147e3846 2349 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
9ba1f565 2350 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC		 2351 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2352 maxnest, dumpops, pvlim);
9ba1f565
NC		 2353 }
2354 /* Source filters hide things that are not GVs in these three, so let's
2355 be careful out there. */
27533608 2356 if (IoFMT_NAME(sv))
cea2e8a9 2357 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC		 2358 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2359 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2360 else {
147e3846 2361 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
9ba1f565 2362 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC		 2363 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2364 maxnest, dumpops, pvlim);
9ba1f565 2365 }
27533608 2366 if (IoBOTTOM_NAME(sv))
cea2e8a9 2367 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC		 2368 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2369 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2370 else {
147e3846 2371 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
9ba1f565 2372 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC		 2373 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2374 maxnest, dumpops, pvlim);
9ba1f565 2375 }
27533608 2376 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2377 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2378 else
cea2e8a9 2379 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
147e3846 2380 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
3967c732 2381 break;
206ee256 2382 case SVt_REGEXP:
8d919b0a 2383 dumpregexp:
d63e6659 2384 {
8d919b0a 2385 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO		 2386
2387#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2388 sv_setpv(d,""); \
e3e400ec 2389 append_flags(d, flags, names); \
ec16d31f
YO		 2390 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2391 SvCUR_set(d, SvCUR(d) - 1); \
2392 SvPVX(d)[SvCUR(d)] = '\0'; \
2393 } \
2394} STMT_END
e3e400ec 2395 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
147e3846 2396 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO		 2397 (UV)(r->compflags), SvPVX_const(d));
2398
e3e400ec 2399 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
147e3846 2400 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO		 2401 (UV)(r->extflags), SvPVX_const(d));
2402
147e3846 2403 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
e3e400ec
YO		 2404 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2405 if (r->engine == &PL_core_reg_engine) {
2406 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
147e3846 2407 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
e3e400ec
YO		 2408 (UV)(r->intflags), SvPVX_const(d));
2409 } else {
147e3846 2410 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
d63e6659 2411 (UV)(r->intflags));
e3e400ec
YO		 2412 }
2413#undef SV_SET_STRINGIFY_REGEXP_FLAGS
147e3846 2414 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
d63e6659 2415 (UV)(r->nparens));
147e3846 2416 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
d63e6659 2417 (UV)(r->lastparen));
147e3846 2418 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
d63e6659 2419 (UV)(r->lastcloseparen));
147e3846 2420 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
d63e6659 2421 (IV)(r->minlen));
147e3846 2422 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
d63e6659 2423 (IV)(r->minlenret));
147e3846 2424 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
d63e6659 2425 (UV)(r->gofs));
147e3846 2426 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
d63e6659 2427 (UV)(r->pre_prefix));
147e3846 2428 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
d63e6659 2429 (IV)(r->sublen));
147e3846 2430 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
6502e081 2431 (IV)(r->suboffset));
147e3846 2432 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
6502e081 2433 (IV)(r->subcoffset));
d63e6659 2434 if (r->subbeg)
147e3846 2435 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
d63e6659
DM		 2436 PTR2UV(r->subbeg),
2437 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2438 else
2439 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
147e3846 2440 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
d63e6659 2441 PTR2UV(r->mother_re));
01ffd0f1
FC		 2442 if (nest < maxnest && r->mother_re)
2443 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2444 maxnest, dumpops, pvlim);
147e3846 2445 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
d63e6659 2446 PTR2UV(r->paren_names));
147e3846 2447 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
d63e6659 2448 PTR2UV(r->substrs));
147e3846 2449 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
d63e6659 2450 PTR2UV(r->pprivate));
147e3846 2451 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
d63e6659 2452 PTR2UV(r->offs));
147e3846 2453 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
d63c20f2 2454 PTR2UV(r->qr_anoncv));
db2c6cb3 2455#ifdef PERL_ANY_COW
147e3846 2456 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
d63e6659
DM		 2457 PTR2UV(r->saved_copy));
2458#endif
2459 }
206ee256 2460 break;
3967c732 2461 }
5f954473 2462 SvREFCNT_dec_NN(d);
3967c732
JD		 2463}
2464
36b1c95c
MH		 2465/*
2466=for apidoc sv_dump
2467
2468Dumps the contents of an SV to the C<STDERR> filehandle.
2469
2470For an example of its output, see L<Devel::Peek>.
2471
2472=cut
2473*/
2474
3967c732 2475void
864dbfa3 2476Perl_sv_dump(pTHX_ SV *sv)
3967c732 2477{
769b28f4 2478 if (sv && SvROK(sv))
d1029faa
JP		 2479 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2480 else
2481 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2482}
bd16a5f0
IZ		 2483
2484int
2485Perl_runops_debug(pTHX)
2486{
1fced1a2 2487#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
87058c31
DM		 2488 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2489
2490 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2491#endif
2492
bd16a5f0 2493 if (!PL_op) {
9b387841 2494 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ		 2495 return 0;
2496 }
9f3673fb 2497 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2498 do {
75d476e2
S		 2499#ifdef PERL_TRACE_OPS
2500 ++PL_op_exec_cnt[PL_op->op_type];
2501#endif
1fced1a2 2502#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
87058c31
DM		 2503 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2504 Perl_croak_nocontext(
2505 "panic: previous op failed to extend arg stack: "
2506 "base=%p, sp=%p, hwm=%p\n",
2507 PL_stack_base, PL_stack_sp,
2508 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2509 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2510#endif
bd16a5f0 2511 if (PL_debug) {
991bab54
DM		 2512 ENTER;
2513 SAVETMPS;
b9ac451d 2514 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0 2515 PerlIO_printf(Perl_debug_log,
147e3846 2516 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
bd16a5f0
IZ		 2517 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2518 PTR2UV(*PL_watchaddr));
d6721266
DM		 2519 if (DEBUG_s_TEST_) {
2520 if (DEBUG_v_TEST_) {
2521 PerlIO_printf(Perl_debug_log, "\n");
2522 deb_stack_all();
2523 }
2524 else
2525 debstack();
2526 }
2527
2528
bd16a5f0
IZ		 2529 if (DEBUG_t_TEST_) debop(PL_op);
2530 if (DEBUG_P_TEST_) debprof(PL_op);
991bab54
DM		 2531 FREETMPS;
2532 LEAVE;
bd16a5f0 2533 }
fe83c362 2534
3f6bd23a 2535 PERL_DTRACE_PROBE_OP(PL_op);
16c91539 2536 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2537 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2538 PERL_ASYNC_CHECK();
bd16a5f0 2539
1fced1a2 2540#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
978b1859
DM		 2541 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2542 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
87058c31 2543#endif
bd16a5f0
IZ		 2544 TAINT_NOT;
2545 return 0;
2546}
2547
f9b02e42
DM		 2548
2549/* print the names of the n lexical vars starting at pad offset off */
2550
f9db5646 2551STATIC void
f9b02e42
DM		 2552S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2553{
2554 PADNAME *sv;
2555 CV * const cv = deb_curcv(cxstack_ix);
2556 PADNAMELIST *comppad = NULL;
2557 int i;
2558
2559 if (cv) {
2560 PADLIST * const padlist = CvPADLIST(cv);
2561 comppad = PadlistNAMES(padlist);
2562 }
2563 if (paren)
2564 PerlIO_printf(Perl_debug_log, "(");
2565 for (i = 0; i < n; i++) {
2566 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
147e3846 2567 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
f9b02e42 2568 else
147e3846 2569 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
f9b02e42
DM		 2570 (UV)(off+i));
2571 if (i < n - 1)
2572 PerlIO_printf(Perl_debug_log, ",");
2573 }
2574 if (paren)
2575 PerlIO_printf(Perl_debug_log, ")");
2576}
2577
2578
fedf30e1
DM		 2579/* append to the out SV, the name of the lexical at offset off in the CV
2580 * cv */
2581
ec48399d 2582static void
fedf30e1
DM		 2583S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2584 bool paren, bool is_scalar)
2585{
2586 PADNAME *sv;
2587 PADNAMELIST *namepad = NULL;
2588 int i;
2589
2590 if (cv) {
2591 PADLIST * const padlist = CvPADLIST(cv);
2592 namepad = PadlistNAMES(padlist);
2593 }
2594
2595 if (paren)
2596 sv_catpvs_nomg(out, "(");
2597 for (i = 0; i < n; i++) {
2598 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2599 {
2600 STRLEN cur = SvCUR(out);
147e3846 2601 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
26334c4d
FC		 2602 UTF8fARG(1, PadnameLEN(sv) - 1,
2603 PadnamePV(sv) + 1));
fedf30e1
DM		 2604 if (is_scalar)
2605 SvPVX(out)[cur] = '$';
2606 }
2607 else
147e3846 2608 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
fedf30e1
DM		 2609 if (i < n - 1)
2610 sv_catpvs_nomg(out, ",");
2611 }
2612 if (paren)
2613 sv_catpvs_nomg(out, "(");
2614}
2615
2616
ec48399d 2617static void
8bbe2fa8 2618S_append_gv_name(pTHX_ GV *gv, SV *out)
fedf30e1
DM		 2619{
2620 SV *sv;
2621 if (!gv) {
2622 sv_catpvs_nomg(out, "<NULLGV>");
2623 return;
2624 }
2625 sv = newSV(0);
2626 gv_fullname4(sv, gv, NULL, FALSE);
147e3846 2627 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
fedf30e1
DM		 2628 SvREFCNT_dec_NN(sv);
2629}
2630
2631#ifdef USE_ITHREADS
dc3c1c70
DM		 2632# define ITEM_SV(item) (comppad ? \
2633 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
fedf30e1
DM		 2634#else
2635# define ITEM_SV(item) UNOP_AUX_item_sv(item)
2636#endif
2637
2638
2639/* return a temporary SV containing a stringified representation of
48ee9c0e 2640 * the op_aux field of a MULTIDEREF op, associated with CV cv
fedf30e1
DM		 2641 */
2642
2643SV*
48ee9c0e 2644Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
fedf30e1
DM		 2645{
2646 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2647 UV actions = items->uv;
2648 SV *sv;
2649 bool last = 0;
2650 bool is_hash = FALSE;
2651 int derefs = 0;
ff94d24c 2652 SV *out = newSVpvn_flags("",0,SVs_TEMP);
fedf30e1 2653#ifdef USE_ITHREADS
dc3c1c70
DM		 2654 PAD *comppad;
2655
2656 if (cv) {
2657 PADLIST *padlist = CvPADLIST(cv);
2658 comppad = PadlistARRAY(padlist)[1];
2659 }
2660 else
2661 comppad = NULL;
fedf30e1
DM		 2662#endif
2663
48ee9c0e 2664 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
fedf30e1
DM		 2665
2666 while (!last) {
2667 switch (actions & MDEREF_ACTION_MASK) {
2668
2669 case MDEREF_reload:
2670 actions = (++items)->uv;
2671 continue;
2b5060ae 2672 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2673
2674 case MDEREF_HV_padhv_helem:
2675 is_hash = TRUE;
2b5060ae 2676 /* FALLTHROUGH */
fedf30e1
DM		 2677 case MDEREF_AV_padav_aelem:
2678 derefs = 1;
2679 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2680 goto do_elem;
2b5060ae 2681 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2682
2683 case MDEREF_HV_gvhv_helem:
2684 is_hash = TRUE;
2b5060ae 2685 /* FALLTHROUGH */
fedf30e1
DM		 2686 case MDEREF_AV_gvav_aelem:
2687 derefs = 1;
dc3c1c70
DM		 2688 items++;
2689 sv = ITEM_SV(items);
8bbe2fa8 2690 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2691 goto do_elem;
2b5060ae 2692 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2693
2694 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2695 is_hash = TRUE;
2b5060ae 2696 /* FALLTHROUGH */
fedf30e1 2697 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
dc3c1c70
DM		 2698 items++;
2699 sv = ITEM_SV(items);
8bbe2fa8 2700 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2701 goto do_vivify_rv2xv_elem;
2b5060ae 2702 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2703
2704 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2705 is_hash = TRUE;
2b5060ae 2706 /* FALLTHROUGH */
fedf30e1
DM		 2707 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2708 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2709 goto do_vivify_rv2xv_elem;
2b5060ae 2710 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2711
2712 case MDEREF_HV_pop_rv2hv_helem:
2713 case MDEREF_HV_vivify_rv2hv_helem:
2714 is_hash = TRUE;
2b5060ae 2715 /* FALLTHROUGH */
fedf30e1
DM		 2716 do_vivify_rv2xv_elem:
2717 case MDEREF_AV_pop_rv2av_aelem:
2718 case MDEREF_AV_vivify_rv2av_aelem:
2719 if (!derefs++)
2720 sv_catpvs_nomg(out, "->");
2721 do_elem:
2722 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2723 sv_catpvs_nomg(out, "->");
2724 last = 1;
2725 break;
2726 }
2727
2728 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2729 switch (actions & MDEREF_INDEX_MASK) {
2730 case MDEREF_INDEX_const:
2731 if (is_hash) {
dc3c1c70
DM		 2732 items++;
2733 sv = ITEM_SV(items);
2734 if (!sv)
2735 sv_catpvs_nomg(out, "???");
2736 else {
2737 STRLEN cur;
2738 char *s;
2739 s = SvPV(sv, cur);
2740 pv_pretty(out, s, cur, 30,
2741 NULL, NULL,
2742 (PERL_PV_PRETTY_NOCLEAR
2743 |PERL_PV_PRETTY_QUOTE
2744 |PERL_PV_PRETTY_ELLIPSES));
2745 }
fedf30e1
DM		 2746 }
2747 else
147e3846 2748 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
fedf30e1
DM		 2749 break;
2750 case MDEREF_INDEX_padsv:
2751 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2752 break;
2753 case MDEREF_INDEX_gvsv:
dc3c1c70
DM		 2754 items++;
2755 sv = ITEM_SV(items);
8bbe2fa8 2756 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM		 2757 break;
2758 }
2759 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2760
2761 if (actions & MDEREF_FLAG_last)
2762 last = 1;
2763 is_hash = FALSE;
2764
2765 break;
2766
2767 default:
2768 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2769 (int)(actions & MDEREF_ACTION_MASK));
2770 last = 1;
2771 break;
2772
2773 } /* switch */
2774
2775 actions >>= MDEREF_SHIFT;
2776 } /* while */
2777 return out;
2778}
2779
2780
e839e6ed
DM		 2781/* Return a temporary SV containing a stringified representation of
2782 * the op_aux field of a MULTICONCAT op. Note that if the aux contains
2783 * both plain and utf8 versions of the const string and indices, only
2784 * the first is displayed.
2785 */
2786
2787SV*
2788Perl_multiconcat_stringify(pTHX_ const OP *o)
2789{
2790 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
2791 UNOP_AUX_item *lens;
2792 STRLEN len;
ca84e88e 2793 SSize_t nargs;
e839e6ed
DM		 2794 char *s;
2795 SV *out = newSVpvn_flags("", 0, SVs_TEMP);
2796
2797 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
2798
ca84e88e 2799 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
e839e6ed 2800 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
b5bf9f73 2801 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
e839e6ed
DM		 2802 if (!s) {
2803 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
b5bf9f73 2804 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
e839e6ed
DM		 2805 sv_catpvs(out, "UTF8 ");
2806 }
2807 pv_pretty(out, s, len, 50,
2808 NULL, NULL,
2809 (PERL_PV_PRETTY_NOCLEAR
2810 |PERL_PV_PRETTY_QUOTE
2811 |PERL_PV_PRETTY_ELLIPSES));
2812
2813 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
ca84e88e 2814 while (nargs-- >= 0) {
b5bf9f73 2815 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
e839e6ed
DM		 2816 lens++;
2817 }
2818 return out;
2819}
2820
2821
bd16a5f0 2822I32
6867be6d 2823Perl_debop(pTHX_ const OP *o)
bd16a5f0 2824{
7918f24d
NC		 2825 PERL_ARGS_ASSERT_DEBOP;
2826
1045810a
IZ		 2827 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2828 return 0;
2829
bd16a5f0
IZ		 2830 Perl_deb(aTHX_ "%s", OP_NAME(o));
2831 switch (o->op_type) {
2832 case OP_CONST:
996c9baa 2833 case OP_HINTSEVAL:
6cefa69e 2834 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2835 * may not be active here, so check.
6cefa69e 2836 * Looks like only during compiling the pads are illegal.
7367e658 2837 */
6cefa69e
RU		 2838#ifdef USE_ITHREADS
2839 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2840#endif
7367e658 2841 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ		 2842 break;
2843 case OP_GVSV:
2844 case OP_GV:
e18c4116
DM		 2845 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2846 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
bd16a5f0 2847 break;
a7fd8ef6 2848
bd16a5f0
IZ		 2849 case OP_PADSV:
2850 case OP_PADAV:
2851 case OP_PADHV:
4fa06845 2852 case OP_ARGELEM:
f9b02e42
DM		 2853 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2854 break;
fedf30e1 2855
a7fd8ef6 2856 case OP_PADRANGE:
f9b02e42
DM		 2857 S_deb_padvar(aTHX_ o->op_targ,
2858 o->op_private & OPpPADRANGE_COUNTMASK, 1);
bd16a5f0 2859 break;
a7fd8ef6 2860
fedf30e1 2861 case OP_MULTIDEREF:
147e3846 2862 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
ac892e4a 2863 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
fedf30e1
DM		 2864 break;
2865
e839e6ed
DM		 2866 case OP_MULTICONCAT:
2867 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2868 SVfARG(multiconcat_stringify(o)));
2869 break;
2870
bd16a5f0 2871 default:
091ab601 2872 break;
bd16a5f0
IZ		 2873 }
2874 PerlIO_printf(Perl_debug_log, "\n");
2875 return 0;
2876}
2877
1e85b658
DM		 2878
2879/*
2880=for apidoc op_class
2881
2882Given an op, determine what type of struct it has been allocated as.
2883Returns one of the OPclass enums, such as OPclass_LISTOP.
2884
2885=cut
2886*/
2887
2888
2889OPclass
2890Perl_op_class(pTHX_ const OP *o)
2891{
2892 bool custom = 0;
2893
2894 if (!o)
2895 return OPclass_NULL;
2896
2897 if (o->op_type == 0) {
2898 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2899 return OPclass_COP;
2900 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2901 }
2902
2903 if (o->op_type == OP_SASSIGN)
2904 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2905
2906 if (o->op_type == OP_AELEMFAST) {
2907#ifdef USE_ITHREADS
2908 return OPclass_PADOP;
2909#else
2910 return OPclass_SVOP;
2911#endif
2912 }
2913
2914#ifdef USE_ITHREADS
2915 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2916 o->op_type == OP_RCATLINE)
2917 return OPclass_PADOP;
2918#endif
2919
2920 if (o->op_type == OP_CUSTOM)
2921 custom = 1;
2922
2923 switch (OP_CLASS(o)) {
2924 case OA_BASEOP:
2925 return OPclass_BASEOP;
2926
2927 case OA_UNOP:
2928 return OPclass_UNOP;
2929
2930 case OA_BINOP:
2931 return OPclass_BINOP;
2932
2933 case OA_LOGOP:
2934 return OPclass_LOGOP;
2935
2936 case OA_LISTOP:
2937 return OPclass_LISTOP;
2938
2939 case OA_PMOP:
2940 return OPclass_PMOP;
2941
2942 case OA_SVOP:
2943 return OPclass_SVOP;
2944
2945 case OA_PADOP:
2946 return OPclass_PADOP;
2947
2948 case OA_PVOP_OR_SVOP:
2949 /*
2950 * Character translations (tr///) are usually a PVOP, keeping a
2951 * pointer to a table of shorts used to look up translations.
2952 * Under utf8, however, a simple table isn't practical; instead,
2953 * the OP is an SVOP (or, under threads, a PADOP),
2954 * and the SV is a reference to a swash
2955 * (i.e., an RV pointing to an HV).
2956 */
2957 return (!custom &&
2958 (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2959 )
2960#if defined(USE_ITHREADS)
2961 ? OPclass_PADOP : OPclass_PVOP;
2962#else
2963 ? OPclass_SVOP : OPclass_PVOP;
2964#endif
2965
2966 case OA_LOOP:
2967 return OPclass_LOOP;
2968
2969 case OA_COP:
2970 return OPclass_COP;
2971
2972 case OA_BASEOP_OR_UNOP:
2973 /*
2974 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2975 * whether parens were seen. perly.y uses OPf_SPECIAL to
2976 * signal whether a BASEOP had empty parens or none.
2977 * Some other UNOPs are created later, though, so the best
2978 * test is OPf_KIDS, which is set in newUNOP.
2979 */
2980 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2981
2982 case OA_FILESTATOP:
2983 /*
2984 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2985 * the OPf_REF flag to distinguish between OP types instead of the
2986 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2987 * return OPclass_UNOP so that walkoptree can find our children. If
2988 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2989 * (no argument to the operator) it's an OP; with OPf_REF set it's
2990 * an SVOP (and op_sv is the GV for the filehandle argument).
2991 */
2992 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2993#ifdef USE_ITHREADS
2994 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2995#else
2996 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
2997#endif
2998 case OA_LOOPEXOP:
2999 /*
3000 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
3001 * label was omitted (in which case it's a BASEOP) or else a term was
3002 * seen. In this last case, all except goto are definitely PVOP but
3003 * goto is either a PVOP (with an ordinary constant label), an UNOP
3004 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
3005 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
3006 * get set.
3007 */
3008 if (o->op_flags & OPf_STACKED)
3009 return OPclass_UNOP;
3010 else if (o->op_flags & OPf_SPECIAL)
3011 return OPclass_BASEOP;
3012 else
3013 return OPclass_PVOP;
3014 case OA_METHOP:
3015 return OPclass_METHOP;
3016 case OA_UNOP_AUX:
3017 return OPclass_UNOP_AUX;
3018 }
3019 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3020 OP_NAME(o));
3021 return OPclass_BASEOP;
3022}
3023
3024
3025
bd16a5f0 3026STATIC CV*
dc6240c9 3027S_deb_curcv(pTHX_ I32 ix)
bd16a5f0 3028{
dc6240c9
DM		 3029 PERL_SI *si = PL_curstackinfo;
3030 for (; ix >=0; ix--) {
3031 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3032
3033 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3034 return cx->blk_sub.cv;
3035 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3036 return cx->blk_eval.cv;
3037 else if (ix == 0 && si->si_type == PERLSI_MAIN)
3038 return PL_main_cv;
3039 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3040 && si->si_type == PERLSI_SORT)
3041 {
3042 /* fake sort sub; use CV of caller */
3043 si = si->si_prev;
3044 ix = si->si_cxix + 1;
3045 }
3046 }
3047 return NULL;
bd16a5f0
IZ		 3048}
3049
3050void
3051Perl_watch(pTHX_ char **addr)
3052{
7918f24d
NC		 3053 PERL_ARGS_ASSERT_WATCH;
3054
bd16a5f0
IZ		 3055 PL_watchaddr = addr;
3056 PL_watchok = *addr;
147e3846 3057 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
bd16a5f0
IZ		 3058 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3059}
3060
3061STATIC void
e1ec3a88 3062S_debprof(pTHX_ const OP *o)
bd16a5f0 3063{
7918f24d
NC		 3064 PERL_ARGS_ASSERT_DEBPROF;
3065
61f9802b 3066 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 3067 return;
bd16a5f0 3068 if (!PL_profiledata)
a02a5408 3069 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ		 3070 ++PL_profiledata[o->op_type];
3071}
3072
3073void
3074Perl_debprofdump(pTHX)
3075{
3076 unsigned i;
3077 if (!PL_profiledata)
3078 return;
3079 for (i = 0; i < MAXO; i++) {
3080 if (PL_profiledata[i])
3081 PerlIO_printf(Perl_debug_log,
3082 "%5lu %s\n", (unsigned long)PL_profiledata[i],
3083 PL_op_name[i]);
3084 }
3085}
66610fdd 3086
3b721df9 3087
66610fdd 3088/*
14d04a33 3089 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3090 */
Unnamed repository; edit this file 'description' to name the repository.