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