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