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