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