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