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