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