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