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
Raise deprecation for qr/(?foo})/
[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:
7896dde7
Z		 1224 case OP_ENTERGIVEN:
1225 case OP_ENTERWHEN:
cd6e4874
DM		 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:
a1106334
DM		 1266 if (o->op_private & (OPpTRANS_FROM_UTF | OPpTRANS_TO_UTF)) {
1267 /* utf8: table stored as a swash */
1268#ifndef USE_ITHREADS
1269 /* with ITHREADS, swash is stored in the pad, and the right pad
1270 * may not be active here, so skip */
f49e8464 1271 S_opdump_indent(aTHX_ o, level, bar, file,
a1106334
DM		 1272 "SWASH = 0x%" UVxf "\n",
1273 PTR2UV(MUTABLE_SV(cSVOPo->op_sv)));
1274#endif
1275 }
1276 else {
1277 const OPtrans_map * const tbl = (OPtrans_map*)cPVOPo->op_pv;
1278 SSize_t i, size = tbl->size;
1279
1280 S_opdump_indent(aTHX_ o, level, bar, file,
1281 "TABLE = 0x%" UVxf "\n",
1282 PTR2UV(tbl));
1283 S_opdump_indent(aTHX_ o, level, bar, file,
1284 " SIZE: 0x%" UVxf "\n", (UV)size);
1285
1286 /* dump size+1 values, to include the extra slot at the end */
1287 for (i = 0; i <= size; i++) {
1288 short val = tbl->map[i];
1289 if ((i & 0xf) == 0)
1290 S_opdump_indent(aTHX_ o, level, bar, file,
1291 " %4" UVxf ":", (UV)i);
1292 if (val < 0)
1293 PerlIO_printf(file, " %2" IVdf, (IV)val);
1294 else
1295 PerlIO_printf(file, " %02" UVxf, (UV)val);
1296
1297 if ( i == size || (i & 0xf) == 0xf)
1298 PerlIO_printf(file, "\n");
1299 }
1300 }
1301 break;
f49e8464 1302
abd07ec0 1303
a0d0e21e
LW		 1304 default:
1305 break;
79072805 1306 }
11343788 1307 if (o->op_flags & OPf_KIDS) {
79072805 1308 OP *kid;
cd6e4874
DM		 1309 level++;
1310 bar <<= 1;
e6dae479 1311 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
cd6e4874
DM		 1312 S_do_op_dump_bar(aTHX_ level,
1313 (bar | cBOOL(OpHAS_SIBLING(kid))),
1314 file, kid);
8d063cd8 1315 }
3967c732
JD		 1316}
1317
cd6e4874
DM		 1318
1319void
1320Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
1321{
1322 S_do_op_dump_bar(aTHX_ level, 0, file, o);
1323}
1324
1325
36b1c95c
MH		 1326/*
1327=for apidoc op_dump
1328
1329Dumps the optree starting at OP C<o> to C<STDERR>.
1330
1331=cut
1332*/
1333
3967c732 1334void
6867be6d 1335Perl_op_dump(pTHX_ const OP *o)
3967c732 1336{
7918f24d 1337 PERL_ARGS_ASSERT_OP_DUMP;
3967c732 1338 do_op_dump(0, Perl_debug_log, o);
8d063cd8
LW		 1339}
1340
8adcabd8 1341void
864dbfa3 1342Perl_gv_dump(pTHX_ GV *gv)
378cc40b 1343{
0eb335df
BF		 1344 STRLEN len;
1345 const char* name;
1346 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1347
79072805 1348 if (!gv) {
760ac839 1349 PerlIO_printf(Perl_debug_log, "{}\n");
378cc40b
LW		 1350 return;
1351 }
8990e307 1352 sv = sv_newmortal();
760ac839 1353 PerlIO_printf(Perl_debug_log, "{\n");
bd61b366 1354 gv_fullname3(sv, gv, NULL);
0eb335df
BF		 1355 name = SvPV_const(sv, len);
1356 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1357 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
79072805 1358 if (gv != GvEGV(gv)) {
bd61b366 1359 gv_efullname3(sv, GvEGV(gv), NULL);
0eb335df
BF		 1360 name = SvPV_const(sv, len);
1361 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1362 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
8adcabd8 1363 }
38d7fd8b 1364 (void)PerlIO_putc(Perl_debug_log, '\n');
cea2e8a9 1365 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
8d063cd8
LW		 1366}
1367
14befaf4 1368
afe38520 1369/* map magic types to the symbolic names
14befaf4
DM		 1370 * (with the PERL_MAGIC_ prefixed stripped)
1371 */
1372
27da23d5 1373static const struct { const char type; const char *name; } magic_names[] = {
16bc0f48 1374#include "mg_names.inc"
516a5887 1375 /* this null string terminates the list */
b9ac451d 1376 { 0, NULL },
14befaf4
DM		 1377};
1378
8adcabd8 1379void
6867be6d 1380Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
8d063cd8 1381{
7918f24d
NC		 1382 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1383
3967c732 1384 for (; mg; mg = mg->mg_moremagic) {
b900a521 1385 Perl_dump_indent(aTHX_ level, file,
147e3846 1386 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
3967c732 1387 if (mg->mg_virtual) {
bfed75c6 1388 const MGVTBL * const v = mg->mg_virtual;
2d1f1fe5
NC		 1389 if (v >= PL_magic_vtables
1390 && v < PL_magic_vtables + magic_vtable_max) {
1391 const U32 i = v - PL_magic_vtables;
1392 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1393 }
3967c732 1394 else
147e3846
KW		 1395 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1396 UVxf "\n", PTR2UV(v));
3967c732
JD		 1397 }
1398 else
cea2e8a9 1399 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
8d063cd8 1400
3967c732 1401 if (mg->mg_private)
cea2e8a9 1402 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
3967c732 1403
14befaf4
DM		 1404 {
1405 int n;
c445ea15 1406 const char *name = NULL;
27da23d5 1407 for (n = 0; magic_names[n].name; n++) {
14befaf4
DM		 1408 if (mg->mg_type == magic_names[n].type) {
1409 name = magic_names[n].name;
1410 break;
1411 }
1412 }
1413 if (name)
1414 Perl_dump_indent(aTHX_ level, file,
1415 " MG_TYPE = PERL_MAGIC_%s\n", name);
1416 else
1417 Perl_dump_indent(aTHX_ level, file,
1418 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1419 }
3967c732
JD		 1420
1421 if (mg->mg_flags) {
cea2e8a9 1422 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
cb50f42d
YST		 1423 if (mg->mg_type == PERL_MAGIC_envelem &&
1424 mg->mg_flags & MGf_TAINTEDDIR)
cea2e8a9 1425 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
4c02285a
FR		 1426 if (mg->mg_type == PERL_MAGIC_regex_global &&
1427 mg->mg_flags & MGf_MINMATCH)
1428 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
3967c732 1429 if (mg->mg_flags & MGf_REFCOUNTED)
cea2e8a9 1430 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1431 if (mg->mg_flags & MGf_GSKIP)
cea2e8a9 1432 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
4c02285a
FR		 1433 if (mg->mg_flags & MGf_COPY)
1434 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1435 if (mg->mg_flags & MGf_DUP)
1436 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1437 if (mg->mg_flags & MGf_LOCAL)
1438 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
25fdce4a
FC		 1439 if (mg->mg_type == PERL_MAGIC_regex_global &&
1440 mg->mg_flags & MGf_BYTES)
1441 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
3967c732
JD		 1442 }
1443 if (mg->mg_obj) {
147e3846 1444 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
28d8d7f4
YO		 1445 PTR2UV(mg->mg_obj));
1446 if (mg->mg_type == PERL_MAGIC_qr) {
07bc277f 1447 REGEXP* const re = (REGEXP *)mg->mg_obj;
61f9802b 1448 SV * const dsv = sv_newmortal();
866c78d1 1449 const char * const s
4c02285a 1450 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
28d8d7f4 1451 60, NULL, NULL,
95b611b0 1452 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
3c8556c3 1453 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
28d8d7f4 1454 );
6483fb35 1455 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
147e3846 1456 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
07bc277f 1457 (IV)RX_REFCNT(re));
28d8d7f4
YO		 1458 }
1459 if (mg->mg_flags & MGf_REFCOUNTED)
3967c732
JD		 1460 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1461 }
1462 if (mg->mg_len)
894356b3 1463 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1464 if (mg->mg_ptr) {
147e3846 1465 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
3967c732 1466 if (mg->mg_len >= 0) {
7e8c5dac 1467 if (mg->mg_type != PERL_MAGIC_utf8) {
17605be7 1468 SV * const sv = newSVpvs("");
7e8c5dac 1469 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
17605be7 1470 SvREFCNT_dec_NN(sv);
7e8c5dac 1471 }
3967c732
JD		 1472 }
1473 else if (mg->mg_len == HEf_SVKEY) {
1474 PerlIO_puts(file, " => HEf_SVKEY\n");
ad64d0ec
NC		 1475 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1476 maxnest, dumpops, pvlim); /* MG is already +1 */
3967c732
JD		 1477 continue;
1478 }
866f9d6c 1479 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
3967c732 1480 else
866f9d6c
FC		 1481 PerlIO_puts(
1482 file,
1483 " ???? - " __FILE__
1484 " does not know how to handle this MG_LEN"
1485 );
38d7fd8b 1486 (void)PerlIO_putc(file, '\n');
3967c732 1487 }
7e8c5dac 1488 if (mg->mg_type == PERL_MAGIC_utf8) {
61f9802b 1489 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7e8c5dac
HS		 1490 if (cache) {
1491 IV i;
1492 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1493 Perl_dump_indent(aTHX_ level, file,
147e3846 1494 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
7e8c5dac
HS		 1495 i,
1496 (UV)cache[i * 2],
1497 (UV)cache[i * 2 + 1]);
1498 }
1499 }
378cc40b 1500 }
3967c732
JD		 1501}
1502
1503void
6867be6d 1504Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1505{
b9ac451d 1506 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732
JD		 1507}
1508
1509void
e1ec3a88 1510Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1511{
bfcb3514 1512 const char *hvname;
7918f24d
NC		 1513
1514 PERL_ARGS_ASSERT_DO_HV_DUMP;
1515
147e3846 1516 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
bfcb3514 1517 if (sv && (hvname = HvNAME_get(sv)))
d7d51f4b
YO		 1518 {
1519 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1520 name which quite legally could contain insane things like tabs, newlines, nulls or
1521 other scary crap - this should produce sane results - except maybe for unicode package
1522 names - but we will wait for someone to file a bug on that - demerphq */
0eb335df
BF		 1523 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1524 PerlIO_printf(file, "\t\"%s\"\n",
1525 generic_pv_escape( tmpsv, hvname,
1526 HvNAMELEN(sv), HvNAMEUTF8(sv)));
d7d51f4b 1527 }
79072805 1528 else
38d7fd8b 1529 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1530}
1531
1532void
e1ec3a88 1533Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1534{
7918f24d
NC		 1535 PERL_ARGS_ASSERT_DO_GV_DUMP;
1536
147e3846 1537 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
0eb335df
BF		 1538 if (sv && GvNAME(sv)) {
1539 SV * const tmpsv = newSVpvs("");
1540 PerlIO_printf(file, "\t\"%s\"\n",
1541 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1542 }
c90c0ff4 1543 else
38d7fd8b 1544 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1545}
1546
1547void
e1ec3a88 1548Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1549{
7918f24d
NC		 1550 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1551
147e3846 1552 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
3967c732 1553 if (sv && GvNAME(sv)) {
0eb335df 1554 SV *tmp = newSVpvs_flags("", SVs_TEMP);
bfcb3514 1555 const char *hvname;
0eb335df
BF		 1556 HV * const stash = GvSTASH(sv);
1557 PerlIO_printf(file, "\t");
6f3289f0 1558 /* TODO might have an extra \" here */
0eb335df
BF		 1559 if (stash && (hvname = HvNAME_get(stash))) {
1560 PerlIO_printf(file, "\"%s\" :: \"",
1561 generic_pv_escape(tmp, hvname,
1562 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1563 }
1564 PerlIO_printf(file, "%s\"\n",
1565 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
8d063cd8 1566 }
3967c732 1567 else
38d7fd8b 1568 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1569}
1570
a0c2f4dd
NC		 1571const struct flag_to_name first_sv_flags_names[] = {
1572 {SVs_TEMP, "TEMP,"},
1573 {SVs_OBJECT, "OBJECT,"},
1574 {SVs_GMG, "GMG,"},
1575 {SVs_SMG, "SMG,"},
1576 {SVs_RMG, "RMG,"},
1577 {SVf_IOK, "IOK,"},
1578 {SVf_NOK, "NOK,"},
1579 {SVf_POK, "POK,"}
1580};
1581
1582const struct flag_to_name second_sv_flags_names[] = {
1583 {SVf_OOK, "OOK,"},
1584 {SVf_FAKE, "FAKE,"},
1585 {SVf_READONLY, "READONLY,"},
fd01b4b7 1586 {SVf_PROTECT, "PROTECT,"},
a0c2f4dd 1587 {SVf_BREAK, "BREAK,"},
a0c2f4dd
NC		 1588 {SVp_IOK, "pIOK,"},
1589 {SVp_NOK, "pNOK,"},
1590 {SVp_POK, "pPOK,"}
1591};
1592
ae1f06a1
NC		 1593const struct flag_to_name cv_flags_names[] = {
1594 {CVf_ANON, "ANON,"},
1595 {CVf_UNIQUE, "UNIQUE,"},
1596 {CVf_CLONE, "CLONE,"},
1597 {CVf_CLONED, "CLONED,"},
1598 {CVf_CONST, "CONST,"},
1599 {CVf_NODEBUG, "NODEBUG,"},
1600 {CVf_LVALUE, "LVALUE,"},
1601 {CVf_METHOD, "METHOD,"},
cfc1e951 1602 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1603 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1604 {CVf_DYNFILE, "DYNFILE,"},
8fa6a409 1605 {CVf_AUTOLOAD, "AUTOLOAD,"},
e4555ecf 1606 {CVf_HASEVAL, "HASEVAL,"},
bfbc3ad9 1607 {CVf_SLABBED, "SLABBED,"},
bf9a4d2d 1608 {CVf_NAMED, "NAMED,"},
82487b59 1609 {CVf_LEXICAL, "LEXICAL,"},
31d45e0c 1610 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC		 1611};
1612
1613const struct flag_to_name hv_flags_names[] = {
1614 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1615 {SVphv_LAZYDEL, "LAZYDEL,"},
1616 {SVphv_HASKFLAGS, "HASKFLAGS,"},
45eaf8af 1617 {SVf_AMAGIC, "OVERLOAD,"},
ae1f06a1
NC		 1618 {SVphv_CLONEABLE, "CLONEABLE,"}
1619};
1620
1621const struct flag_to_name gp_flags_names[] = {
1622 {GVf_INTRO, "INTRO,"},
1623 {GVf_MULTI, "MULTI,"},
1624 {GVf_ASSUMECV, "ASSUMECV,"},
ae1f06a1
NC		 1625};
1626
1627const struct flag_to_name gp_flags_imported_names[] = {
1628 {GVf_IMPORTED_SV, " SV"},
1629 {GVf_IMPORTED_AV, " AV"},
1630 {GVf_IMPORTED_HV, " HV"},
1631 {GVf_IMPORTED_CV, " CV"},
1632};
1633
0d331aaf
YO		 1634/* NOTE: this structure is mostly duplicative of one generated by
1635 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1636 * the two. - Yves */
e3e400ec 1637const struct flag_to_name regexp_extflags_names[] = {
d63e6659
DM		 1638 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1639 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1640 {RXf_PMf_FOLD, "PMf_FOLD,"},
1641 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
334afb3e 1642 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
d63e6659 1643 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
41d7c59e 1644 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
8e1490ee 1645 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
dbc200c5 1646 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
d63e6659 1647 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
d63e6659
DM		 1648 {RXf_CHECK_ALL, "CHECK_ALL,"},
1649 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1650 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1651 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1652 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
dbc200c5 1653 {RXf_SPLIT, "SPLIT,"},
d63e6659
DM		 1654 {RXf_COPY_DONE, "COPY_DONE,"},
1655 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1656 {RXf_TAINTED, "TAINTED,"},
1657 {RXf_START_ONLY, "START_ONLY,"},
dbc200c5 1658 {RXf_SKIPWHITE, "SKIPWHITE,"},
d63e6659
DM		 1659 {RXf_WHITE, "WHITE,"},
1660 {RXf_NULL, "NULL,"},
1661};
1662
0d331aaf
YO		 1663/* NOTE: this structure is mostly duplicative of one generated by
1664 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1665 * the two. - Yves */
e3e400ec
YO		 1666const struct flag_to_name regexp_core_intflags_names[] = {
1667 {PREGf_SKIP, "SKIP,"},
0d331aaf
YO		 1668 {PREGf_IMPLICIT, "IMPLICIT,"},
1669 {PREGf_NAUGHTY, "NAUGHTY,"},
e3e400ec
YO		 1670 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1671 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
0d331aaf 1672 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
e3e400ec 1673 {PREGf_NOSCAN, "NOSCAN,"},
58430ea8
YO		 1674 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1675 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
8e1490ee
YO		 1676 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1677 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1678 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
e3e400ec
YO		 1679};
1680
c24d0595
DM		 1681/* Perl_do_sv_dump():
1682 *
1683 * level: amount to indent the output
1684 * sv: the object to dump
1685 * nest: the current level of recursion
1686 * maxnest: the maximum allowed level of recursion
1687 * dumpops: if true, also dump the ops associated with a CV
1688 * pvlim: limit on the length of any strings that are output
1689 * */
1690
3967c732 1691void
864dbfa3 1692Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1693{
cea89e20 1694 SV *d;
e1ec3a88 1695 const char *s;
3967c732
JD		 1696 U32 flags;
1697 U32 type;
1698
7918f24d
NC		 1699 PERL_ARGS_ASSERT_DO_SV_DUMP;
1700
3967c732 1701 if (!sv) {
cea2e8a9 1702 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1703 return;
378cc40b 1704 }
2ef28da1 1705
3967c732
JD		 1706 flags = SvFLAGS(sv);
1707 type = SvTYPE(sv);
79072805 1708
e0bbf362
DM		 1709 /* process general SV flags */
1710
cea89e20 1711 d = Perl_newSVpvf(aTHX_
147e3846 1712 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
56431972 1713 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS		 1714 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1715 (int)(PL_dumpindent*level), "");
8d063cd8 1716
0f94cb1f 1717 if ((flags & SVs_PADSTALE))
9a214eec 1718 sv_catpv(d, "PADSTALE,");
0f94cb1f 1719 if ((flags & SVs_PADTMP))
9a214eec 1720 sv_catpv(d, "PADTMP,");
a0c2f4dd 1721 append_flags(d, flags, first_sv_flags_names);
810b8aa5
GS		 1722 if (flags & SVf_ROK) {
1723 sv_catpv(d, "ROK,");
1724 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1725 }
45eaf8af 1726 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
a0c2f4dd 1727 append_flags(d, flags, second_sv_flags_names);
7db6405c
FC		 1728 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1729 && type != SVt_PVAV) {
1ccdb730
NC		 1730 if (SvPCS_IMPORTED(sv))
1731 sv_catpv(d, "PCS_IMPORTED,");
1732 else
9660f481 1733 sv_catpv(d, "SCREAM,");
1ccdb730 1734 }
3967c732 1735
e0bbf362
DM		 1736 /* process type-specific SV flags */
1737
3967c732
JD		 1738 switch (type) {
1739 case SVt_PVCV:
1740 case SVt_PVFM:
ae1f06a1 1741 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD		 1742 break;
1743 case SVt_PVHV:
ae1f06a1 1744 append_flags(d, flags, hv_flags_names);
3967c732 1745 break;
926fc7b6
DM		 1746 case SVt_PVGV:
1747 case SVt_PVLV:
1748 if (isGV_with_GP(sv)) {
ae1f06a1 1749 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1750 }
926fc7b6 1751 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD		 1752 sv_catpv(d, "IMPORT");
1753 if (GvIMPORTED(sv) == GVf_IMPORTED)
1754 sv_catpv(d, "ALL,");
1755 else {
1756 sv_catpv(d, "(");
ae1f06a1 1757 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
3967c732
JD		 1758 sv_catpv(d, " ),");
1759 }
1760 }
924ba076 1761 /* FALLTHROUGH */
a5c7cb08 1762 case SVt_PVMG:
25da4f38 1763 default:
69c678eb 1764 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1765 break;
a5c7cb08 1766
11ca45c0
NC		 1767 case SVt_PVAV:
1768 break;
3967c732 1769 }
86f0d186
NC		 1770 /* SVphv_SHAREKEYS is also 0x20000000 */
1771 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1772 sv_catpv(d, "UTF8");
3967c732 1773
b162af07
SP		 1774 if (*(SvEND(d) - 1) == ',') {
1775 SvCUR_set(d, SvCUR(d) - 1);
1776 SvPVX(d)[SvCUR(d)] = '\0';
1777 }
3967c732 1778 sv_catpv(d, ")");
b15aece3 1779 s = SvPVX_const(d);
3967c732 1780
e0bbf362
DM		 1781 /* dump initial SV details */
1782
fd0854ff 1783#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1784 Perl_dump_indent(aTHX_ level, file,
147e3846 1785 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
fd0854ff
DM		 1786 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1787 sv->sv_debug_line,
1788 sv->sv_debug_inpad ? "for" : "by",
1789 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1790 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM		 1791 sv->sv_debug_serial
1792 );
fd0854ff 1793#endif
cea2e8a9 1794 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM		 1795
1796 /* Dump SV type */
1797
5357ca29
NC		 1798 if (type < SVt_LAST) {
1799 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1800
1801 if (type == SVt_NULL) {
5f954473 1802 SvREFCNT_dec_NN(d);
5357ca29
NC		 1803 return;
1804 }
1805 } else {
147e3846 1806 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
5f954473 1807 SvREFCNT_dec_NN(d);
3967c732
JD		 1808 return;
1809 }
e0bbf362
DM		 1810
1811 /* Dump general SV fields */
1812
27bd069f 1813 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC		 1814 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1815 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1816 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1817 if (SvIsUV(sv)
765f542d 1818 )
147e3846 1819 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
cf2093f6 1820 else
147e3846 1821 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
38d7fd8b 1822 (void)PerlIO_putc(file, '\n');
3967c732 1823 }
e0bbf362 1824
0f94cb1f 1825 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1826 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1827 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1828 || type == SVt_NV) {
67d796ae 1829 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
88cb8500 1830 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
67d796ae 1831 RESTORE_LC_NUMERIC_UNDERLYING();
3967c732 1832 }
e0bbf362 1833
3967c732 1834 if (SvROK(sv)) {
147e3846
KW		 1835 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1836 PTR2UV(SvRV(sv)));
3967c732
JD		 1837 if (nest < maxnest)
1838 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1839 }
e0bbf362 1840
cea89e20 1841 if (type < SVt_PV) {
5f954473 1842 SvREFCNT_dec_NN(d);
3967c732 1843 return;
cea89e20 1844 }
e0bbf362 1845
5a3c7349
FC		 1846 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1847 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
8d919b0a
FC		 1848 const bool re = isREGEXP(sv);
1849 const char * const ptr =
1850 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1851 if (ptr) {
69240efd 1852 STRLEN delta;
7a4bba22 1853 if (SvOOK(sv)) {
69240efd 1854 SvOOK_offset(sv, delta);
147e3846 1855 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
5186cc12 1856 (UV) delta);
69240efd
NC		 1857 } else {
1858 delta = 0;
7a4bba22 1859 }
147e3846
KW		 1860 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1861 PTR2UV(ptr));
7a4bba22
NC		 1862 if (SvOOK(sv)) {
1863 PerlIO_printf(file, "( %s . ) ",
8d919b0a 1864 pv_display(d, ptr - delta, delta, 0,
7a4bba22
NC		 1865 pvlim));
1866 }
ad3f05ad
KW		 1867 if (type == SVt_INVLIST) {
1868 PerlIO_printf(file, "\n");
1869 /* 4 blanks indents 2 beyond the PV, etc */
1870 _invlist_dump(file, level, " ", sv);
1871 }
1872 else {
685bfc3c
KW		 1873 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1874 re ? 0 : SvLEN(sv),
1875 pvlim));
1876 if (SvUTF8(sv)) /* the 6? \x{....} */
1877 PerlIO_printf(file, " [UTF8 \"%s\"]",
1878 sv_uni_display(d, sv, 6 * SvCUR(sv),
1879 UNI_DISPLAY_QQ));
1880 PerlIO_printf(file, "\n");
ad3f05ad 1881 }
147e3846 1882 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
89042fa4 1883 if (re && type == SVt_PVLV)
5956eec7 1884 /* LV-as-REGEXP usurps len field to store pointer to
89042fa4
DM		 1885 * regexp struct */
1886 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n",
1887 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
1888 else
147e3846 1889 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
8d919b0a 1890 (IV)SvLEN(sv));
93c10d60 1891#ifdef PERL_COPY_ON_WRITE
db2c6cb3
FC		 1892 if (SvIsCOW(sv) && SvLEN(sv))
1893 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1894 CowREFCNT(sv));
1895#endif
3967c732
JD		 1896 }
1897 else
cea2e8a9 1898 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1899 }
e0bbf362 1900
3967c732 1901 if (type >= SVt_PVMG) {
0f94cb1f 1902 if (SvMAGIC(sv))
8530ff28 1903 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
3967c732
JD		 1904 if (SvSTASH(sv))
1905 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC		 1906
1907 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
147e3846
KW		 1908 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1909 (IV)BmUSEFUL(sv));
c13a5c80 1910 }
3967c732 1911 }
e0bbf362
DM		 1912
1913 /* Dump type-specific SV fields */
1914
3967c732 1915 switch (type) {
3967c732 1916 case SVt_PVAV:
147e3846
KW		 1917 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1918 PTR2UV(AvARRAY(sv)));
3967c732 1919 if (AvARRAY(sv) != AvALLOC(sv)) {
147e3846
KW		 1920 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1921 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1922 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1923 PTR2UV(AvALLOC(sv)));
3967c732
JD		 1924 }
1925 else
38d7fd8b 1926 (void)PerlIO_putc(file, '\n');
147e3846
KW		 1927 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1928 (IV)AvFILLp(sv));
1929 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1930 (IV)AvMAX(sv));
ed0faf2e 1931 SvPVCLEAR(d);
11ca45c0
NC		 1932 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1933 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP		 1934 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1935 SvCUR(d) ? SvPVX_const(d) + 1 : "");
476fafda 1936 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
c70927a6 1937 SSize_t count;
476fafda
DM		 1938 SV **svp = AvARRAY(MUTABLE_AV(sv));
1939 for (count = 0;
1940 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1941 count++, svp++)
1942 {
1943 SV* const elt = *svp;
147e3846
KW		 1944 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1945 (IV)count);
476fafda 1946 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
3967c732
JD		 1947 }
1948 }
1949 break;
5d27ee4a
DD		 1950 case SVt_PVHV: {
1951 U32 usedkeys;
0c22a733
DM		 1952 if (SvOOK(sv)) {
1953 struct xpvhv_aux *const aux = HvAUX(sv);
147e3846 1954 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
0c22a733
DM		 1955 (UV)aux->xhv_aux_flags);
1956 }
147e3846 1957 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
1186f821 1958 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
5d27ee4a 1959 if (HvARRAY(sv) && usedkeys) {
3967c732
JD		 1960 /* Show distribution of HEs in the ARRAY */
1961 int freq[200];
c3caa5c3 1962#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
3967c732
JD		 1963 int i;
1964 int max = 0;
5d27ee4a 1965 U32 pow2 = 2, keys = usedkeys;
65202027 1966 NV theoret, sum = 0;
3967c732
JD		 1967
1968 PerlIO_printf(file, " (");
1969 Zero(freq, FREQ_MAX + 1, int);
eb160463 1970 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL		 1971 HE* h;
1972 int count = 0;
3967c732
JD		 1973 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1974 count++;
1975 if (count > FREQ_MAX)
1976 count = FREQ_MAX;
1977 freq[count]++;
1978 if (max < count)
1979 max = count;
1980 }
1981 for (i = 0; i <= max; i++) {
1982 if (freq[i]) {
1983 PerlIO_printf(file, "%d%s:%d", i,
1984 (i == FREQ_MAX) ? "+" : "",
1985 freq[i]);
1986 if (i != max)
1987 PerlIO_printf(file, ", ");
1988 }
1989 }
38d7fd8b 1990 (void)PerlIO_putc(file, ')');
b8fa94d8
MG		 1991 /* The "quality" of a hash is defined as the total number of
1992 comparisons needed to access every element once, relative
1993 to the expected number needed for a random hash.
1994
1995 The total number of comparisons is equal to the sum of
e76cd0fa
AMS		 1996 the squares of the number of entries in each bucket.
1997 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG		 1998 value is
1999 n + n(n-1)/2k
2000 */
2001
3967c732
JD		 2002 for (i = max; i > 0; i--) { /* Precision: count down. */
2003 sum += freq[i] * i * i;
2004 }
155aba94 2005 while ((keys = keys >> 1))
3967c732 2006 pow2 = pow2 << 1;
5d27ee4a 2007 theoret = usedkeys;
b8fa94d8 2008 theoret += theoret * (theoret-1)/pow2;
38d7fd8b 2009 (void)PerlIO_putc(file, '\n');
147e3846
KW		 2010 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
2011 NVff "%%", theoret/sum*100);
3967c732 2012 }
38d7fd8b 2013 (void)PerlIO_putc(file, '\n');
147e3846
KW		 2014 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
2015 (IV)usedkeys);
9faf471a
NC		 2016 {
2017 STRLEN count = 0;
2018 HE **ents = HvARRAY(sv);
2019
2020 if (ents) {
2021 HE *const *const last = ents + HvMAX(sv);
2022 count = last + 1 - ents;
2023
2024 do {
2025 if (!*ents)
2026 --count;
2027 } while (++ents <= last);
2028 }
2029
147e3846 2030 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
8bf4c401 2031 (UV)count);
9faf471a 2032 }
147e3846
KW		 2033 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
2034 (IV)HvMAX(sv));
e1a7ec8d 2035 if (SvOOK(sv)) {
147e3846
KW		 2036 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
2037 (IV)HvRITER_get(sv));
2038 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
2039 PTR2UV(HvEITER_get(sv)));
6a5b4183 2040#ifdef PERL_HASH_RANDOMIZE_KEYS
147e3846
KW		 2041 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
2042 (UV)HvRAND_get(sv));
e1a7ec8d 2043 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
147e3846
KW		 2044 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
2045 (UV)HvLASTRAND_get(sv));
e1a7ec8d 2046 }
6a5b4183 2047#endif
38d7fd8b 2048 (void)PerlIO_putc(file, '\n');
e1a7ec8d 2049 }
8d2f4536 2050 {
b9ac451d 2051 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536 2052 if (mg && mg->mg_obj) {
147e3846 2053 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
8d2f4536
NC		 2054 }
2055 }
bfcb3514 2056 {
b9ac451d 2057 const char * const hvname = HvNAME_get(sv);
0eb335df 2058 if (hvname) {
6f3289f0
DM		 2059 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2060 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
0eb335df
BF		 2061 generic_pv_escape( tmpsv, hvname,
2062 HvNAMELEN(sv), HvNAMEUTF8(sv)));
2063 }
bfcb3514 2064 }
86f55936 2065 if (SvOOK(sv)) {
ad64d0ec 2066 AV * const backrefs
85fbaab2 2067 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 2068 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC		 2069 if (HvAUX(sv)->xhv_name_count)
2070 Perl_dump_indent(aTHX_
147e3846 2071 level, file, " NAMECOUNT = %" IVdf "\n",
7afc2217 2072 (IV)HvAUX(sv)->xhv_name_count
67e04715 2073 );
15d9236d 2074 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC		 2075 const I32 count = HvAUX(sv)->xhv_name_count;
2076 if (count) {
2077 SV * const names = newSVpvs_flags("", SVs_TEMP);
2078 /* The starting point is the first element if count is
2079 positive and the second element if count is negative. */
2080 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2081 + (count < 0 ? 1 : 0);
2082 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
2083 + (count < 0 ? -count : count);
2084 while (hekp < endp) {
8e5993c4 2085 if (*hekp) {
6f3289f0 2086 SV *tmp = newSVpvs_flags("", SVs_TEMP);
0eb335df
BF		 2087 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
2088 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
ec3405c8
NC		 2089 } else {
2090 /* This should never happen. */
2091 sv_catpvs(names, ", (null)");
67e04715 2092 }
ec3405c8
NC		 2093 ++hekp;
2094 }
67e04715
FC		 2095 Perl_dump_indent(aTHX_
2096 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
2097 );
2098 }
0eb335df
BF		 2099 else {
2100 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
2101 const char *const hvename = HvENAME_get(sv);
67e04715 2102 Perl_dump_indent(aTHX_
0eb335df
BF		 2103 level, file, " ENAME = \"%s\"\n",
2104 generic_pv_escape(tmp, hvename,
2105 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
2106 }
67e04715 2107 }
86f55936 2108 if (backrefs) {
147e3846 2109 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
86f55936 2110 PTR2UV(backrefs));
ad64d0ec 2111 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC		 2112 dumpops, pvlim);
2113 }
7d88e6c4 2114 if (meta) {
0eb335df 2115 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
147e3846
KW		 2116 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
2117 UVxf ")\n",
0eb335df
BF		 2118 generic_pv_escape( tmpsv, meta->mro_which->name,
2119 meta->mro_which->length,
2120 (meta->mro_which->kflags & HVhek_UTF8)),
7d88e6c4 2121 PTR2UV(meta->mro_which));
147e3846
KW		 2122 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
2123 UVxf "\n",
7d88e6c4 2124 (UV)meta->cache_gen);
147e3846 2125 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
7d88e6c4
NC		 2126 (UV)meta->pkg_gen);
2127 if (meta->mro_linear_all) {
147e3846
KW		 2128 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
2129 UVxf "\n",
7d88e6c4
NC		 2130 PTR2UV(meta->mro_linear_all));
2131 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
2132 dumpops, pvlim);
2133 }
2134 if (meta->mro_linear_current) {
147e3846
KW		 2135 Perl_dump_indent(aTHX_ level, file,
2136 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
7d88e6c4
NC		 2137 PTR2UV(meta->mro_linear_current));
2138 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
2139 dumpops, pvlim);
2140 }
2141 if (meta->mro_nextmethod) {
147e3846
KW		 2142 Perl_dump_indent(aTHX_ level, file,
2143 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
7d88e6c4
NC		 2144 PTR2UV(meta->mro_nextmethod));
2145 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
2146 dumpops, pvlim);
2147 }
2148 if (meta->isa) {
147e3846 2149 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
7d88e6c4
NC		 2150 PTR2UV(meta->isa));
2151 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
2152 dumpops, pvlim);
2153 }
2154 }
86f55936 2155 }
b5698553 2156 if (nest < maxnest) {
cbab3169 2157 HV * const hv = MUTABLE_HV(sv);
b5698553
TH		 2158 STRLEN i;
2159 HE *he;
cbab3169 2160
b5698553
TH		 2161 if (HvARRAY(hv)) {
2162 int count = maxnest - nest;
2163 for (i=0; i <= HvMAX(hv); i++) {
2164 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
2165 U32 hash;
2166 SV * keysv;
2167 const char * keypv;
2168 SV * elt;
7dc86639 2169 STRLEN len;
b5698553
TH		 2170
2171 if (count-- <= 0) goto DONEHV;
2172
2173 hash = HeHASH(he);
2174 keysv = hv_iterkeysv(he);
2175 keypv = SvPV_const(keysv, len);
2176 elt = HeVAL(he);
cbab3169 2177
7dc86639
YO		 2178 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
2179 if (SvUTF8(keysv))
2180 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH		 2181 if (HvEITER_get(hv) == he)
2182 PerlIO_printf(file, "[CURRENT] ");
147e3846 2183 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
7dc86639
YO		 2184 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
2185 }
b5698553
TH		 2186 }
2187 DONEHV:;
2188 }
3967c732
JD		 2189 }
2190 break;
5d27ee4a 2191 } /* case SVt_PVHV */
e0bbf362 2192
3967c732 2193 case SVt_PVCV:
8fa6a409 2194 if (CvAUTOLOAD(sv)) {
0eb335df 2195 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
6f3289f0 2196 STRLEN len;
8fa6a409 2197 const char *const name = SvPV_const(sv, len);
0eb335df
BF		 2198 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
2199 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
8fa6a409
FC		 2200 }
2201 if (SvPOK(sv)) {
6f3289f0
DM		 2202 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2203 const char *const proto = CvPROTO(sv);
0eb335df
BF		 2204 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
2205 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
2206 SvUTF8(sv)));
cbf82dd0 2207 }
924ba076 2208 /* FALLTHROUGH */
3967c732
JD		 2209 case SVt_PVFM:
2210 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC		 2211 if (!CvISXSUB(sv)) {
2212 if (CvSTART(sv)) {
27604593
DM		 2213 if (CvSLABBED(sv))
2214 Perl_dump_indent(aTHX_ level, file,
147e3846 2215 " SLAB = 0x%" UVxf "\n",
27604593
DM		 2216 PTR2UV(CvSTART(sv)));
2217 else
2218 Perl_dump_indent(aTHX_ level, file,
147e3846 2219 " START = 0x%" UVxf " ===> %" IVdf "\n",
d04ba589
NC		 2220 PTR2UV(CvSTART(sv)),
2221 (IV)sequence_num(CvSTART(sv)));
2222 }
147e3846 2223 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
d04ba589
NC		 2224 PTR2UV(CvROOT(sv)));
2225 if (CvROOT(sv) && dumpops) {
2226 do_op_dump(level+1, file, CvROOT(sv));
2227 }
2228 } else {
126f53f3 2229 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 2230
147e3846 2231 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
b1886099
NC		 2232
2233 if (constant) {
147e3846 2234 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
b1886099
NC		 2235 " (CONST SV)\n",
2236 PTR2UV(CvXSUBANY(sv).any_ptr));
2237 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
2238 pvlim);
2239 } else {
147e3846 2240 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
b1886099
NC		 2241 (IV)CvXSUBANY(sv).any_i32);
2242 }
2243 }
3610c89f
FC		 2244 if (CvNAMED(sv))
2245 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2246 HEK_KEY(CvNAME_HEK((CV *)sv)));
2247 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 2248 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
147e3846
KW		 2249 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
2250 IVdf "\n", (IV)CvDEPTH(sv));
2251 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
2252 (UV)CvFLAGS(sv));
2253 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
eacbb379 2254 if (!CvISXSUB(sv)) {
147e3846 2255 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
eacbb379
DD		 2256 if (nest < maxnest) {
2257 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2258 }
3967c732 2259 }
eacbb379 2260 else
db6e00bd 2261 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
3967c732 2262 {
b9ac451d 2263 const CV * const outside = CvOUTSIDE(sv);
147e3846 2264 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
57def98f 2265 PTR2UV(outside),
cf2093f6
JH		 2266 (!outside ? "null"
2267 : CvANON(outside) ? "ANON"
2268 : (outside == PL_main_cv) ? "MAIN"
2269 : CvUNIQUE(outside) ? "UNIQUE"
b24fda9d
BF		 2270 : CvGV(outside) ?
2271 generic_pv_escape(
2272 newSVpvs_flags("", SVs_TEMP),
2273 GvNAME(CvGV(outside)),
2274 GvNAMELEN(CvGV(outside)),
2275 GvNAMEUTF8(CvGV(outside)))
2276 : "UNDEFINED"));
3967c732 2277 }
704b97aa
FC		 2278 if (CvOUTSIDE(sv)
2279 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
ad64d0ec 2280 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2281 break;
e0bbf362 2282
926fc7b6
DM		 2283 case SVt_PVGV:
2284 case SVt_PVLV:
b9ac451d
AL		 2285 if (type == SVt_PVLV) {
2286 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
147e3846
KW		 2287 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2288 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2289 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2290 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
305b8651 2291 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
b9ac451d
AL		 2292 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2293 dumpops, pvlim);
2294 }
8d919b0a 2295 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM		 2296 if (!isGV_with_GP(sv))
2297 break;
6f3289f0
DM		 2298 {
2299 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2300 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2301 generic_pv_escape(tmpsv, GvNAME(sv),
2302 GvNAMELEN(sv),
2303 GvNAMEUTF8(sv)));
2304 }
147e3846 2305 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
3967c732 2306 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
147e3846
KW		 2307 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2308 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
f472eb5c
GS		 2309 if (!GvGP(sv))
2310 break;
147e3846
KW		 2311 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2312 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2313 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2314 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2315 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2316 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2317 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2318 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2319 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
008009b0
FC		 2320 " (%s)\n",
2321 (UV)GvGPFLAGS(sv),
71afaece 2322 "");
147e3846 2323 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
b195d487 2324 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
3967c732
JD		 2325 do_gv_dump (level, file, " EGV", GvEGV(sv));
2326 break;
2327 case SVt_PVIO:
147e3846
KW		 2328 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2329 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2330 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2331 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2332 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2333 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2334 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
27533608 2335 if (IoTOP_NAME(sv))
cea2e8a9 2336 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC		 2337 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2338 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2339 else {
147e3846 2340 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
9ba1f565 2341 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC		 2342 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2343 maxnest, dumpops, pvlim);
9ba1f565
NC		 2344 }
2345 /* Source filters hide things that are not GVs in these three, so let's
2346 be careful out there. */
27533608 2347 if (IoFMT_NAME(sv))
cea2e8a9 2348 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC		 2349 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2350 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2351 else {
147e3846 2352 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
9ba1f565 2353 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC		 2354 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2355 maxnest, dumpops, pvlim);
9ba1f565 2356 }
27533608 2357 if (IoBOTTOM_NAME(sv))
cea2e8a9 2358 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC		 2359 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2360 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2361 else {
147e3846 2362 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
9ba1f565 2363 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC		 2364 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2365 maxnest, dumpops, pvlim);
9ba1f565 2366 }
27533608 2367 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2368 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2369 else
cea2e8a9 2370 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
147e3846 2371 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
3967c732 2372 break;
206ee256 2373 case SVt_REGEXP:
8d919b0a 2374 dumpregexp:
d63e6659 2375 {
8d919b0a 2376 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO		 2377
2378#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2379 sv_setpv(d,""); \
e3e400ec 2380 append_flags(d, flags, names); \
ec16d31f
YO		 2381 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2382 SvCUR_set(d, SvCUR(d) - 1); \
2383 SvPVX(d)[SvCUR(d)] = '\0'; \
2384 } \
2385} STMT_END
e3e400ec 2386 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
147e3846 2387 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO		 2388 (UV)(r->compflags), SvPVX_const(d));
2389
e3e400ec 2390 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
147e3846 2391 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO		 2392 (UV)(r->extflags), SvPVX_const(d));
2393
147e3846 2394 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
e3e400ec
YO		 2395 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2396 if (r->engine == &PL_core_reg_engine) {
2397 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
147e3846 2398 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
e3e400ec
YO		 2399 (UV)(r->intflags), SvPVX_const(d));
2400 } else {
147e3846 2401 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
d63e6659 2402 (UV)(r->intflags));
e3e400ec
YO		 2403 }
2404#undef SV_SET_STRINGIFY_REGEXP_FLAGS
147e3846 2405 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
d63e6659 2406 (UV)(r->nparens));
147e3846 2407 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
d63e6659 2408 (UV)(r->lastparen));
147e3846 2409 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
d63e6659 2410 (UV)(r->lastcloseparen));
147e3846 2411 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
d63e6659 2412 (IV)(r->minlen));
147e3846 2413 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
d63e6659 2414 (IV)(r->minlenret));
147e3846 2415 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
d63e6659 2416 (UV)(r->gofs));
147e3846 2417 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
d63e6659 2418 (UV)(r->pre_prefix));
147e3846 2419 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
d63e6659 2420 (IV)(r->sublen));
147e3846 2421 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
6502e081 2422 (IV)(r->suboffset));
147e3846 2423 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
6502e081 2424 (IV)(r->subcoffset));
d63e6659 2425 if (r->subbeg)
147e3846 2426 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
d63e6659
DM		 2427 PTR2UV(r->subbeg),
2428 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2429 else
2430 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
147e3846 2431 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
d63e6659 2432 PTR2UV(r->mother_re));
01ffd0f1
FC		 2433 if (nest < maxnest && r->mother_re)
2434 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2435 maxnest, dumpops, pvlim);
147e3846 2436 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
d63e6659 2437 PTR2UV(r->paren_names));
147e3846 2438 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
d63e6659 2439 PTR2UV(r->substrs));
147e3846 2440 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
d63e6659 2441 PTR2UV(r->pprivate));
147e3846 2442 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
d63e6659 2443 PTR2UV(r->offs));
147e3846 2444 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
d63c20f2 2445 PTR2UV(r->qr_anoncv));
db2c6cb3 2446#ifdef PERL_ANY_COW
147e3846 2447 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
d63e6659
DM		 2448 PTR2UV(r->saved_copy));
2449#endif
2450 }
206ee256 2451 break;
3967c732 2452 }
5f954473 2453 SvREFCNT_dec_NN(d);
3967c732
JD		 2454}
2455
36b1c95c
MH		 2456/*
2457=for apidoc sv_dump
2458
2459Dumps the contents of an SV to the C<STDERR> filehandle.
2460
2461For an example of its output, see L<Devel::Peek>.
2462
2463=cut
2464*/
2465
3967c732 2466void
864dbfa3 2467Perl_sv_dump(pTHX_ SV *sv)
3967c732 2468{
769b28f4 2469 if (sv && SvROK(sv))
d1029faa
JP		 2470 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2471 else
2472 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2473}
bd16a5f0
IZ		 2474
2475int
2476Perl_runops_debug(pTHX)
2477{
1fced1a2 2478#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
87058c31
DM		 2479 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
2480
2481 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2482#endif
2483
bd16a5f0 2484 if (!PL_op) {
9b387841 2485 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ		 2486 return 0;
2487 }
9f3673fb 2488 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2489 do {
75d476e2
S		 2490#ifdef PERL_TRACE_OPS
2491 ++PL_op_exec_cnt[PL_op->op_type];
2492#endif
1fced1a2 2493#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
87058c31
DM		 2494 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
2495 Perl_croak_nocontext(
2496 "panic: previous op failed to extend arg stack: "
2497 "base=%p, sp=%p, hwm=%p\n",
2498 PL_stack_base, PL_stack_sp,
2499 PL_stack_base + PL_curstackinfo->si_stack_hwm);
2500 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
2501#endif
bd16a5f0 2502 if (PL_debug) {
991bab54
DM		 2503 ENTER;
2504 SAVETMPS;
b9ac451d 2505 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0 2506 PerlIO_printf(Perl_debug_log,
147e3846 2507 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
bd16a5f0
IZ		 2508 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2509 PTR2UV(*PL_watchaddr));
d6721266
DM		 2510 if (DEBUG_s_TEST_) {
2511 if (DEBUG_v_TEST_) {
2512 PerlIO_printf(Perl_debug_log, "\n");
2513 deb_stack_all();
2514 }
2515 else
2516 debstack();
2517 }
2518
2519
bd16a5f0
IZ		 2520 if (DEBUG_t_TEST_) debop(PL_op);
2521 if (DEBUG_P_TEST_) debprof(PL_op);
991bab54
DM		 2522 FREETMPS;
2523 LEAVE;
bd16a5f0 2524 }
fe83c362 2525
3f6bd23a 2526 PERL_DTRACE_PROBE_OP(PL_op);
16c91539 2527 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2528 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2529 PERL_ASYNC_CHECK();
bd16a5f0 2530
1fced1a2 2531#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
978b1859
DM		 2532 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
2533 PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
87058c31 2534#endif
bd16a5f0
IZ		 2535 TAINT_NOT;
2536 return 0;
2537}
2538
f9b02e42
DM		 2539
2540/* print the names of the n lexical vars starting at pad offset off */
2541
f9db5646 2542STATIC void
f9b02e42
DM		 2543S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2544{
2545 PADNAME *sv;
2546 CV * const cv = deb_curcv(cxstack_ix);
2547 PADNAMELIST *comppad = NULL;
2548 int i;
2549
2550 if (cv) {
2551 PADLIST * const padlist = CvPADLIST(cv);
2552 comppad = PadlistNAMES(padlist);
2553 }
2554 if (paren)
2555 PerlIO_printf(Perl_debug_log, "(");
2556 for (i = 0; i < n; i++) {
2557 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
147e3846 2558 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
f9b02e42 2559 else
147e3846 2560 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
f9b02e42
DM		 2561 (UV)(off+i));
2562 if (i < n - 1)
2563 PerlIO_printf(Perl_debug_log, ",");
2564 }
2565 if (paren)
2566 PerlIO_printf(Perl_debug_log, ")");
2567}
2568
2569
fedf30e1
DM		 2570/* append to the out SV, the name of the lexical at offset off in the CV
2571 * cv */
2572
ec48399d 2573static void
fedf30e1
DM		 2574S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2575 bool paren, bool is_scalar)
2576{
2577 PADNAME *sv;
2578 PADNAMELIST *namepad = NULL;
2579 int i;
2580
2581 if (cv) {
2582 PADLIST * const padlist = CvPADLIST(cv);
2583 namepad = PadlistNAMES(padlist);
2584 }
2585
2586 if (paren)
2587 sv_catpvs_nomg(out, "(");
2588 for (i = 0; i < n; i++) {
2589 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2590 {
2591 STRLEN cur = SvCUR(out);
147e3846 2592 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
26334c4d
FC		 2593 UTF8fARG(1, PadnameLEN(sv) - 1,
2594 PadnamePV(sv) + 1));
fedf30e1
DM		 2595 if (is_scalar)
2596 SvPVX(out)[cur] = '$';
2597 }
2598 else
147e3846 2599 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
fedf30e1
DM		 2600 if (i < n - 1)
2601 sv_catpvs_nomg(out, ",");
2602 }
2603 if (paren)
2604 sv_catpvs_nomg(out, "(");
2605}
2606
2607
ec48399d 2608static void
8bbe2fa8 2609S_append_gv_name(pTHX_ GV *gv, SV *out)
fedf30e1
DM		 2610{
2611 SV *sv;
2612 if (!gv) {
2613 sv_catpvs_nomg(out, "<NULLGV>");
2614 return;
2615 }
2616 sv = newSV(0);
2617 gv_fullname4(sv, gv, NULL, FALSE);
147e3846 2618 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
fedf30e1
DM		 2619 SvREFCNT_dec_NN(sv);
2620}
2621
2622#ifdef USE_ITHREADS
dc3c1c70
DM		 2623# define ITEM_SV(item) (comppad ? \
2624 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
fedf30e1
DM		 2625#else
2626# define ITEM_SV(item) UNOP_AUX_item_sv(item)
2627#endif
2628
2629
2630/* return a temporary SV containing a stringified representation of
48ee9c0e 2631 * the op_aux field of a MULTIDEREF op, associated with CV cv
fedf30e1
DM		 2632 */
2633
2634SV*
48ee9c0e 2635Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
fedf30e1
DM		 2636{
2637 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2638 UV actions = items->uv;
2639 SV *sv;
2640 bool last = 0;
2641 bool is_hash = FALSE;
2642 int derefs = 0;
ff94d24c 2643 SV *out = newSVpvn_flags("",0,SVs_TEMP);
fedf30e1 2644#ifdef USE_ITHREADS
dc3c1c70
DM		 2645 PAD *comppad;
2646
2647 if (cv) {
2648 PADLIST *padlist = CvPADLIST(cv);
2649 comppad = PadlistARRAY(padlist)[1];
2650 }
2651 else
2652 comppad = NULL;
fedf30e1
DM		 2653#endif
2654
48ee9c0e 2655 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
fedf30e1
DM		 2656
2657 while (!last) {
2658 switch (actions & MDEREF_ACTION_MASK) {
2659
2660 case MDEREF_reload:
2661 actions = (++items)->uv;
2662 continue;
2b5060ae 2663 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2664
2665 case MDEREF_HV_padhv_helem:
2666 is_hash = TRUE;
2b5060ae 2667 /* FALLTHROUGH */
fedf30e1
DM		 2668 case MDEREF_AV_padav_aelem:
2669 derefs = 1;
2670 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2671 goto do_elem;
2b5060ae 2672 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2673
2674 case MDEREF_HV_gvhv_helem:
2675 is_hash = TRUE;
2b5060ae 2676 /* FALLTHROUGH */
fedf30e1
DM		 2677 case MDEREF_AV_gvav_aelem:
2678 derefs = 1;
dc3c1c70
DM		 2679 items++;
2680 sv = ITEM_SV(items);
8bbe2fa8 2681 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2682 goto do_elem;
2b5060ae 2683 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2684
2685 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2686 is_hash = TRUE;
2b5060ae 2687 /* FALLTHROUGH */
fedf30e1 2688 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
dc3c1c70
DM		 2689 items++;
2690 sv = ITEM_SV(items);
8bbe2fa8 2691 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2692 goto do_vivify_rv2xv_elem;
2b5060ae 2693 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2694
2695 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2696 is_hash = TRUE;
2b5060ae 2697 /* FALLTHROUGH */
fedf30e1
DM		 2698 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2699 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2700 goto do_vivify_rv2xv_elem;
2b5060ae 2701 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2702
2703 case MDEREF_HV_pop_rv2hv_helem:
2704 case MDEREF_HV_vivify_rv2hv_helem:
2705 is_hash = TRUE;
2b5060ae 2706 /* FALLTHROUGH */
fedf30e1
DM		 2707 do_vivify_rv2xv_elem:
2708 case MDEREF_AV_pop_rv2av_aelem:
2709 case MDEREF_AV_vivify_rv2av_aelem:
2710 if (!derefs++)
2711 sv_catpvs_nomg(out, "->");
2712 do_elem:
2713 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2714 sv_catpvs_nomg(out, "->");
2715 last = 1;
2716 break;
2717 }
2718
2719 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2720 switch (actions & MDEREF_INDEX_MASK) {
2721 case MDEREF_INDEX_const:
2722 if (is_hash) {
dc3c1c70
DM		 2723 items++;
2724 sv = ITEM_SV(items);
2725 if (!sv)
2726 sv_catpvs_nomg(out, "???");
2727 else {
2728 STRLEN cur;
2729 char *s;
2730 s = SvPV(sv, cur);
2731 pv_pretty(out, s, cur, 30,
2732 NULL, NULL,
2733 (PERL_PV_PRETTY_NOCLEAR
2734 |PERL_PV_PRETTY_QUOTE
2735 |PERL_PV_PRETTY_ELLIPSES));
2736 }
fedf30e1
DM		 2737 }
2738 else
147e3846 2739 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
fedf30e1
DM		 2740 break;
2741 case MDEREF_INDEX_padsv:
2742 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2743 break;
2744 case MDEREF_INDEX_gvsv:
dc3c1c70
DM		 2745 items++;
2746 sv = ITEM_SV(items);
8bbe2fa8 2747 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM		 2748 break;
2749 }
2750 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2751
2752 if (actions & MDEREF_FLAG_last)
2753 last = 1;
2754 is_hash = FALSE;
2755
2756 break;
2757
2758 default:
2759 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2760 (int)(actions & MDEREF_ACTION_MASK));
2761 last = 1;
2762 break;
2763
2764 } /* switch */
2765
2766 actions >>= MDEREF_SHIFT;
2767 } /* while */
2768 return out;
2769}
2770
2771
e839e6ed
DM		 2772/* Return a temporary SV containing a stringified representation of
2773 * the op_aux field of a MULTICONCAT op. Note that if the aux contains
2774 * both plain and utf8 versions of the const string and indices, only
2775 * the first is displayed.
2776 */
2777
2778SV*
2779Perl_multiconcat_stringify(pTHX_ const OP *o)
2780{
2781 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
2782 UNOP_AUX_item *lens;
2783 STRLEN len;
ca84e88e 2784 SSize_t nargs;
e839e6ed
DM		 2785 char *s;
2786 SV *out = newSVpvn_flags("", 0, SVs_TEMP);
2787
2788 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
2789
ca84e88e 2790 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize;
e839e6ed 2791 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
b5bf9f73 2792 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize;
e839e6ed
DM		 2793 if (!s) {
2794 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
b5bf9f73 2795 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize;
e839e6ed
DM		 2796 sv_catpvs(out, "UTF8 ");
2797 }
2798 pv_pretty(out, s, len, 50,
2799 NULL, NULL,
2800 (PERL_PV_PRETTY_NOCLEAR
2801 |PERL_PV_PRETTY_QUOTE
2802 |PERL_PV_PRETTY_ELLIPSES));
2803
2804 lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
ca84e88e 2805 while (nargs-- >= 0) {
b5bf9f73 2806 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize);
e839e6ed
DM		 2807 lens++;
2808 }
2809 return out;
2810}
2811
2812
bd16a5f0 2813I32
6867be6d 2814Perl_debop(pTHX_ const OP *o)
bd16a5f0 2815{
7918f24d
NC		 2816 PERL_ARGS_ASSERT_DEBOP;
2817
1045810a
IZ		 2818 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2819 return 0;
2820
bd16a5f0
IZ		 2821 Perl_deb(aTHX_ "%s", OP_NAME(o));
2822 switch (o->op_type) {
2823 case OP_CONST:
996c9baa 2824 case OP_HINTSEVAL:
6cefa69e 2825 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2826 * may not be active here, so check.
6cefa69e 2827 * Looks like only during compiling the pads are illegal.
7367e658 2828 */
6cefa69e
RU		 2829#ifdef USE_ITHREADS
2830 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2831#endif
7367e658 2832 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ		 2833 break;
2834 case OP_GVSV:
2835 case OP_GV:
e18c4116
DM		 2836 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2837 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
bd16a5f0 2838 break;
a7fd8ef6 2839
bd16a5f0
IZ		 2840 case OP_PADSV:
2841 case OP_PADAV:
2842 case OP_PADHV:
4fa06845 2843 case OP_ARGELEM:
f9b02e42
DM		 2844 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2845 break;
fedf30e1 2846
a7fd8ef6 2847 case OP_PADRANGE:
f9b02e42
DM		 2848 S_deb_padvar(aTHX_ o->op_targ,
2849 o->op_private & OPpPADRANGE_COUNTMASK, 1);
bd16a5f0 2850 break;
a7fd8ef6 2851
fedf30e1 2852 case OP_MULTIDEREF:
147e3846 2853 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
ac892e4a 2854 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
fedf30e1
DM		 2855 break;
2856
e839e6ed
DM		 2857 case OP_MULTICONCAT:
2858 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
2859 SVfARG(multiconcat_stringify(o)));
2860 break;
2861
bd16a5f0 2862 default:
091ab601 2863 break;
bd16a5f0
IZ		 2864 }
2865 PerlIO_printf(Perl_debug_log, "\n");
2866 return 0;
2867}
2868
1e85b658
DM		 2869
2870/*
2871=for apidoc op_class
2872
2873Given an op, determine what type of struct it has been allocated as.
2874Returns one of the OPclass enums, such as OPclass_LISTOP.
2875
2876=cut
2877*/
2878
2879
2880OPclass
2881Perl_op_class(pTHX_ const OP *o)
2882{
2883 bool custom = 0;
2884
2885 if (!o)
2886 return OPclass_NULL;
2887
2888 if (o->op_type == 0) {
2889 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
2890 return OPclass_COP;
2891 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2892 }
2893
2894 if (o->op_type == OP_SASSIGN)
2895 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP);
2896
2897 if (o->op_type == OP_AELEMFAST) {
2898#ifdef USE_ITHREADS
2899 return OPclass_PADOP;
2900#else
2901 return OPclass_SVOP;
2902#endif
2903 }
2904
2905#ifdef USE_ITHREADS
2906 if (o->op_type == OP_GV || o->op_type == OP_GVSV ||
2907 o->op_type == OP_RCATLINE)
2908 return OPclass_PADOP;
2909#endif
2910
2911 if (o->op_type == OP_CUSTOM)
2912 custom = 1;
2913
2914 switch (OP_CLASS(o)) {
2915 case OA_BASEOP:
2916 return OPclass_BASEOP;
2917
2918 case OA_UNOP:
2919 return OPclass_UNOP;
2920
2921 case OA_BINOP:
2922 return OPclass_BINOP;
2923
2924 case OA_LOGOP:
2925 return OPclass_LOGOP;
2926
2927 case OA_LISTOP:
2928 return OPclass_LISTOP;
2929
2930 case OA_PMOP:
2931 return OPclass_PMOP;
2932
2933 case OA_SVOP:
2934 return OPclass_SVOP;
2935
2936 case OA_PADOP:
2937 return OPclass_PADOP;
2938
2939 case OA_PVOP_OR_SVOP:
2940 /*
2941 * Character translations (tr///) are usually a PVOP, keeping a
2942 * pointer to a table of shorts used to look up translations.
2943 * Under utf8, however, a simple table isn't practical; instead,
2944 * the OP is an SVOP (or, under threads, a PADOP),
2945 * and the SV is a reference to a swash
2946 * (i.e., an RV pointing to an HV).
2947 */
2948 return (!custom &&
2949 (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF))
2950 )
2951#if defined(USE_ITHREADS)
2952 ? OPclass_PADOP : OPclass_PVOP;
2953#else
2954 ? OPclass_SVOP : OPclass_PVOP;
2955#endif
2956
2957 case OA_LOOP:
2958 return OPclass_LOOP;
2959
2960 case OA_COP:
2961 return OPclass_COP;
2962
2963 case OA_BASEOP_OR_UNOP:
2964 /*
2965 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
2966 * whether parens were seen. perly.y uses OPf_SPECIAL to
2967 * signal whether a BASEOP had empty parens or none.
2968 * Some other UNOPs are created later, though, so the best
2969 * test is OPf_KIDS, which is set in newUNOP.
2970 */
2971 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP;
2972
2973 case OA_FILESTATOP:
2974 /*
2975 * The file stat OPs are created via UNI(OP_foo) in toke.c but use
2976 * the OPf_REF flag to distinguish between OP types instead of the
2977 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
2978 * return OPclass_UNOP so that walkoptree can find our children. If
2979 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
2980 * (no argument to the operator) it's an OP; with OPf_REF set it's
2981 * an SVOP (and op_sv is the GV for the filehandle argument).
2982 */
2983 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP :
2984#ifdef USE_ITHREADS
2985 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP);
2986#else
2987 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP);
2988#endif
2989 case OA_LOOPEXOP:
2990 /*
2991 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
2992 * label was omitted (in which case it's a BASEOP) or else a term was
2993 * seen. In this last case, all except goto are definitely PVOP but
2994 * goto is either a PVOP (with an ordinary constant label), an UNOP
2995 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
2996 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
2997 * get set.
2998 */
2999 if (o->op_flags & OPf_STACKED)
3000 return OPclass_UNOP;
3001 else if (o->op_flags & OPf_SPECIAL)
3002 return OPclass_BASEOP;
3003 else
3004 return OPclass_PVOP;
3005 case OA_METHOP:
3006 return OPclass_METHOP;
3007 case OA_UNOP_AUX:
3008 return OPclass_UNOP_AUX;
3009 }
3010 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n",
3011 OP_NAME(o));
3012 return OPclass_BASEOP;
3013}
3014
3015
3016
bd16a5f0 3017STATIC CV*
dc6240c9 3018S_deb_curcv(pTHX_ I32 ix)
bd16a5f0 3019{
dc6240c9
DM		 3020 PERL_SI *si = PL_curstackinfo;
3021 for (; ix >=0; ix--) {
3022 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
3023
3024 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
3025 return cx->blk_sub.cv;
3026 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3027 return cx->blk_eval.cv;
3028 else if (ix == 0 && si->si_type == PERLSI_MAIN)
3029 return PL_main_cv;
3030 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
3031 && si->si_type == PERLSI_SORT)
3032 {
3033 /* fake sort sub; use CV of caller */
3034 si = si->si_prev;
3035 ix = si->si_cxix + 1;
3036 }
3037 }
3038 return NULL;
bd16a5f0
IZ		 3039}
3040
3041void
3042Perl_watch(pTHX_ char **addr)
3043{
7918f24d
NC		 3044 PERL_ARGS_ASSERT_WATCH;
3045
bd16a5f0
IZ		 3046 PL_watchaddr = addr;
3047 PL_watchok = *addr;
147e3846 3048 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
bd16a5f0
IZ		 3049 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
3050}
3051
3052STATIC void
e1ec3a88 3053S_debprof(pTHX_ const OP *o)
bd16a5f0 3054{
7918f24d
NC		 3055 PERL_ARGS_ASSERT_DEBPROF;
3056
61f9802b 3057 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 3058 return;
bd16a5f0 3059 if (!PL_profiledata)
a02a5408 3060 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ		 3061 ++PL_profiledata[o->op_type];
3062}
3063
3064void
3065Perl_debprofdump(pTHX)
3066{
3067 unsigned i;
3068 if (!PL_profiledata)
3069 return;
3070 for (i = 0; i < MAXO; i++) {
3071 if (PL_profiledata[i])
3072 PerlIO_printf(Perl_debug_log,
3073 "%5lu %s\n", (unsigned long)PL_profiledata[i],
3074 PL_op_name[i]);
3075 }
3076}
66610fdd 3077
3b721df9 3078
66610fdd 3079/*
14d04a33 3080 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3081 */
Unnamed repository; edit this file 'description' to name the repository.