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