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
Rmv unused regex implementation structure element
[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:
0eb335df
BF		 208 if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) {
209 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
147e3846 210 isuni ? "%cx{%02" UVxf "}" : "%cx%02" UVxf,
0eb335df
BF		 211 esc, u);
212 }
213 else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) )
ab3bbdeb 214 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE,
44a2ac75
YO		 215 "%c%03o", esc, c);
216 else
ab3bbdeb 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 }
7996736c 372 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
3967c732
JD		 373 if (sv == &PL_sv_undef) {
374 sv_catpv(t, "SV_UNDEF");
375 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
376 SVs_GMG|SVs_SMG|SVs_RMG)) &&
377 SvREADONLY(sv))
378 goto finish;
379 }
380 else if (sv == &PL_sv_no) {
381 sv_catpv(t, "SV_NO");
382 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
383 SVs_GMG|SVs_SMG|SVs_RMG)) &&
384 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
385 SVp_POK|SVp_NOK)) &&
386 SvCUR(sv) == 0 &&
659c4b96 387 SvNVX(sv) == 0.0)
3967c732
JD		 388 goto finish;
389 }
7996736c 390 else if (sv == &PL_sv_yes) {
3967c732
JD		 391 sv_catpv(t, "SV_YES");
392 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
393 SVs_GMG|SVs_SMG|SVs_RMG)) &&
394 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
395 SVp_POK|SVp_NOK)) &&
396 SvCUR(sv) == 1 &&
b15aece3 397 SvPVX_const(sv) && *SvPVX_const(sv) == '1' &&
659c4b96 398 SvNVX(sv) == 1.0)
3967c732 399 goto finish;
7996736c
MHM		 400 }
401 else {
402 sv_catpv(t, "SV_PLACEHOLDER");
403 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
404 SVs_GMG|SVs_SMG|SVs_RMG)) &&
405 SvREADONLY(sv))
406 goto finish;
3967c732
JD		 407 }
408 sv_catpv(t, ":");
409 }
410 else if (SvREFCNT(sv) == 0) {
411 sv_catpv(t, "(");
412 unref++;
413 }
a3b4c9c6
DM		 414 else if (DEBUG_R_TEST_) {
415 int is_tmp = 0;
e8eb279c 416 SSize_t ix;
a3b4c9c6
DM		 417 /* is this SV on the tmps stack? */
418 for (ix=PL_tmps_ix; ix>=0; ix--) {
419 if (PL_tmps_stack[ix] == sv) {
420 is_tmp = 1;
421 break;
422 }
423 }
d5a163ad
DM		 424 if (is_tmp || SvREFCNT(sv) > 1) {
425 Perl_sv_catpvf(aTHX_ t, "<");
426 if (SvREFCNT(sv) > 1)
147e3846 427 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv));
d5a163ad
DM		 428 if (is_tmp)
429 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t");
430 Perl_sv_catpvf(aTHX_ t, ">");
431 }
04932ac8
DM		 432 }
433
3967c732
JD		 434 if (SvROK(sv)) {
435 sv_catpv(t, "\\");
436 if (SvCUR(t) + unref > 10) {
b162af07 437 SvCUR_set(t, unref + 3);
3967c732
JD		 438 *SvEND(t) = '\0';
439 sv_catpv(t, "...");
440 goto finish;
441 }
ad64d0ec 442 sv = SvRV(sv);
3967c732
JD		 443 goto retry;
444 }
5357ca29
NC		 445 type = SvTYPE(sv);
446 if (type == SVt_PVCV) {
0eb335df
BF		 447 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
448 GV* gvcv = CvGV(sv);
c53e4eb5 449 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv
0eb335df
BF		 450 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv))
451 : "");
3967c732 452 goto finish;
5357ca29
NC		 453 } else if (type < SVt_LAST) {
454 sv_catpv(t, svshorttypenames[type]);
3967c732 455
5357ca29
NC		 456 if (type == SVt_NULL)
457 goto finish;
458 } else {
459 sv_catpv(t, "FREED");
3967c732 460 goto finish;
3967c732
JD		 461 }
462
463 if (SvPOKp(sv)) {
b15aece3 464 if (!SvPVX_const(sv))
3967c732
JD		 465 sv_catpv(t, "(null)");
466 else {
17605be7 467 SV * const tmp = newSVpvs("");
3967c732 468 sv_catpv(t, "(");
5115136b
DM		 469 if (SvOOK(sv)) {
470 STRLEN delta;
471 SvOOK_offset(sv, delta);
472 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127));
473 }
b15aece3 474 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127));
32639b87 475 if (SvUTF8(sv))
b2ff9928 476 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]",
e9569a7a 477 sv_uni_display(tmp, sv, 6 * SvCUR(sv),
c728cb41 478 UNI_DISPLAY_QQ));
17605be7 479 SvREFCNT_dec_NN(tmp);
3967c732
JD		 480 }
481 }
482 else if (SvNOKp(sv)) {
67d796ae 483 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
147e3846 484 Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv));
67d796ae 485 RESTORE_LC_NUMERIC_UNDERLYING();
3967c732 486 }
57def98f 487 else if (SvIOKp(sv)) {
cf2093f6 488 if (SvIsUV(sv))
147e3846 489 Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv));
cf2093f6 490 else
147e3846 491 Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv));
25da4f38 492 }
3967c732
JD		 493 else
494 sv_catpv(t, "()");
2ef28da1 495
3967c732 496 finish:
61f9802b
AL		 497 while (unref--)
498 sv_catpv(t, ")");
9adb2837 499 if (TAINTING_get && sv && SvTAINTED(sv))
59b714e2 500 sv_catpv(t, " [tainted]");
8b6b16e7 501 return SvPV_nolen(t);
3967c732
JD		 502}
503
36b1c95c
MH		 504/*
505=head1 Debugging Utilities
506*/
507
508void
509Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
510{
511 va_list args;
512 PERL_ARGS_ASSERT_DUMP_INDENT;
513 va_start(args, pat);
514 dump_vindent(level, file, pat, &args);
515 va_end(args);
516}
517
518void
519Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
520{
36b1c95c
MH		 521 PERL_ARGS_ASSERT_DUMP_VINDENT;
522 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), "");
523 PerlIO_vprintf(file, pat, *args);
524}
525
526/*
527=for apidoc dump_all
528
529Dumps the entire optree of the current program starting at C<PL_main_root> to
72d33970
FC		 530C<STDERR>. Also dumps the optrees for all visible subroutines in
531C<PL_defstash>.
36b1c95c
MH		 532
533=cut
534*/
535
536void
537Perl_dump_all(pTHX)
538{
539 dump_all_perl(FALSE);
540}
541
542void
543Perl_dump_all_perl(pTHX_ bool justperl)
544{
36b1c95c
MH		 545 PerlIO_setlinebuf(Perl_debug_log);
546 if (PL_main_root)
547 op_dump(PL_main_root);
548 dump_packsubs_perl(PL_defstash, justperl);
549}
550
551/*
552=for apidoc dump_packsubs
553
554Dumps the optrees for all visible subroutines in C<stash>.
555
556=cut
557*/
558
559void
560Perl_dump_packsubs(pTHX_ const HV *stash)
561{
562 PERL_ARGS_ASSERT_DUMP_PACKSUBS;
563 dump_packsubs_perl(stash, FALSE);
564}
565
566void
567Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
568{
36b1c95c
MH		 569 I32 i;
570
571 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL;
572
573 if (!HvARRAY(stash))
574 return;
575 for (i = 0; i <= (I32) HvMAX(stash); i++) {
576 const HE *entry;
577 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
66103581
DM		 578 GV * gv = (GV *)HeVAL(entry);
579 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV)
580 /* unfake a fake GV */
581 (void)CvGV(SvRV(gv));
36b1c95c
MH		 582 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
583 continue;
584 if (GvCVu(gv))
585 dump_sub_perl(gv, justperl);
586 if (GvFORM(gv))
587 dump_form(gv);
588 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
589 const HV * const hv = GvHV(gv);
590 if (hv && (hv != PL_defstash))
591 dump_packsubs_perl(hv, justperl); /* nested package */
592 }
593 }
594 }
595}
596
597void
598Perl_dump_sub(pTHX_ const GV *gv)
599{
600 PERL_ARGS_ASSERT_DUMP_SUB;
601 dump_sub_perl(gv, FALSE);
602}
603
604void
605Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
606{
0eb335df
BF		 607 STRLEN len;
608 SV * const sv = newSVpvs_flags("", SVs_TEMP);
609 SV *tmpsv;
610 const char * name;
36b1c95c
MH		 611
612 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
613
614 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
615 return;
616
0eb335df 617 tmpsv = newSVpvs_flags("", SVs_TEMP);
36b1c95c 618 gv_fullname3(sv, gv, NULL);
0eb335df
BF		 619 name = SvPV_const(sv, len);
620 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
621 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
36b1c95c 622 if (CvISXSUB(GvCV(gv)))
147e3846 623 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
36b1c95c
MH		 624 PTR2UV(CvXSUB(GvCV(gv))),
625 (int)CvXSUBANY(GvCV(gv)).any_i32);
626 else if (CvROOT(GvCV(gv)))
627 op_dump(CvROOT(GvCV(gv)));
628 else
629 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
630}
631
632void
633Perl_dump_form(pTHX_ const GV *gv)
634{
635 SV * const sv = sv_newmortal();
636
637 PERL_ARGS_ASSERT_DUMP_FORM;
638
639 gv_fullname3(sv, gv, NULL);
640 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
641 if (CvROOT(GvFORM(gv)))
642 op_dump(CvROOT(GvFORM(gv)));
643 else
644 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
645}
646
647void
648Perl_dump_eval(pTHX)
649{
36b1c95c
MH		 650 op_dump(PL_eval_root);
651}
652
3967c732 653void
6867be6d 654Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
3967c732
JD		 655{
656 char ch;
657
7918f24d
NC		 658 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
659
8efda520 660 if (!pm)
3967c732 661 return;
3967c732
JD		 662 if (pm->op_pmflags & PMf_ONCE)
663 ch = '?';
664 else
665 ch = '/';
aaa362c4 666 if (PM_GETRE(pm))
2e2d70f2
DM		 667 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c\n",
668 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch);
3967c732 669 else
cea2e8a9 670 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
5012eebe
DM		 671
672 if (pm->op_type == OP_SPLIT)
147e3846 673 Perl_dump_indent(aTHX_ level, file, "TARGOFF/GV = 0x%" UVxf "\n",
5012eebe
DM		 674 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv));
675 else {
676 if (pm->op_pmreplrootu.op_pmreplroot) {
677 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
678 op_dump(pm->op_pmreplrootu.op_pmreplroot);
679 }
3967c732 680 }
5012eebe 681
68e2671b 682 if (pm->op_code_list) {
867940b8
DM		 683 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
684 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
685 do_op_dump(level, file, pm->op_code_list);
686 }
687 else
147e3846 688 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%" UVxf "\n",
867940b8 689 PTR2UV(pm->op_code_list));
68e2671b 690 }
07bc277f 691 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
4199688e 692 SV * const tmpsv = pm_description(pm);
b15aece3 693 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
5f954473 694 SvREFCNT_dec_NN(tmpsv);
3967c732 695 }
3967c732
JD		 696}
697
a0c2f4dd
NC		 698const struct flag_to_name pmflags_flags_names[] = {
699 {PMf_CONST, ",CONST"},
700 {PMf_KEEP, ",KEEP"},
701 {PMf_GLOBAL, ",GLOBAL"},
702 {PMf_CONTINUE, ",CONTINUE"},
703 {PMf_RETAINT, ",RETAINT"},
704 {PMf_EVAL, ",EVAL"},
705 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
d63c20f2 706 {PMf_HAS_CV, ",HAS_CV"},
2a92a973
DM		 707 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
708 {PMf_IS_QR, ",IS_QR"}
a0c2f4dd
NC		 709};
710
b9ac451d 711static SV *
4199688e
AL		 712S_pm_description(pTHX_ const PMOP *pm)
713{
714 SV * const desc = newSVpvs("");
61f9802b 715 const REGEXP * const regex = PM_GETRE(pm);
4199688e
AL		 716 const U32 pmflags = pm->op_pmflags;
717
7918f24d
NC		 718 PERL_ARGS_ASSERT_PM_DESCRIPTION;
719
4199688e
AL		 720 if (pmflags & PMf_ONCE)
721 sv_catpv(desc, ",ONCE");
c737faaf
YO		 722#ifdef USE_ITHREADS
723 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
724 sv_catpv(desc, ":USED");
725#else
726 if (pmflags & PMf_USED)
727 sv_catpv(desc, ":USED");
728#endif
c737faaf 729
68d4833d 730 if (regex) {
284167a5 731 if (RX_ISTAINTED(regex))
68d4833d 732 sv_catpv(desc, ",TAINTED");
07bc277f 733 if (RX_CHECK_SUBSTR(regex)) {
e3e400ec 734 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
68d4833d 735 sv_catpv(desc, ",SCANFIRST");
07bc277f 736 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
68d4833d
AB		 737 sv_catpv(desc, ",ALL");
738 }
dbc200c5
YO		 739 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
740 sv_catpv(desc, ",SKIPWHITE");
4199688e 741 }
68d4833d 742
a0c2f4dd 743 append_flags(desc, pmflags, pmflags_flags_names);
4199688e
AL		 744 return desc;
745}
746
3967c732 747void
864dbfa3 748Perl_pmop_dump(pTHX_ PMOP *pm)
3967c732
JD		 749{
750 do_pmop_dump(0, Perl_debug_log, pm);
79072805
LW		 751}
752
b6f05621
DM		 753/* Return a unique integer to represent the address of op o.
754 * If it already exists in PL_op_sequence, just return it;
755 * otherwise add it.
756 * *** Note that this isn't thread-safe */
294b3b39 757
2814eb74 758STATIC UV
0bd48802 759S_sequence_num(pTHX_ const OP *o)
2814eb74 760{
27da23d5 761 dVAR;
2814eb74
PJ		 762 SV *op,
763 **seq;
93524f2b 764 const char *key;
2814eb74 765 STRLEN len;
b6f05621
DM		 766 if (!o)
767 return 0;
c0fd1b42 768 op = newSVuv(PTR2UV(o));
b6f05621 769 sv_2mortal(op);
93524f2b 770 key = SvPV_const(op, len);
b6f05621
DM		 771 if (!PL_op_sequence)
772 PL_op_sequence = newHV();
773 seq = hv_fetch(PL_op_sequence, key, len, 0);
774 if (seq)
775 return SvUV(*seq);
776 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
777 return PL_op_seq;
2814eb74
PJ		 778}
779
f3574cc6
DM		 780
781
782
783
a0c2f4dd
NC		 784const struct flag_to_name op_flags_names[] = {
785 {OPf_KIDS, ",KIDS"},
786 {OPf_PARENS, ",PARENS"},
a0c2f4dd
NC		 787 {OPf_REF, ",REF"},
788 {OPf_MOD, ",MOD"},
65cccc5e 789 {OPf_STACKED, ",STACKED"},
a0c2f4dd
NC		 790 {OPf_SPECIAL, ",SPECIAL"}
791};
792
75a6ad4a 793
79072805 794void
6867be6d 795Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
79072805 796{
2814eb74 797 UV seq;
e15d5972
AL		 798 const OPCODE optype = o->op_type;
799
7918f24d
NC		 800 PERL_ARGS_ASSERT_DO_OP_DUMP;
801
cea2e8a9 802 Perl_dump_indent(aTHX_ level, file, "{\n");
3967c732 803 level++;
0bd48802 804 seq = sequence_num(o);
2814eb74 805 if (seq)
147e3846 806 PerlIO_printf(file, "%-4" UVuf, seq);
93a17b20 807 else
b6f05621 808 PerlIO_printf(file, "????");
c8db6e60
JH		 809 PerlIO_printf(file,
810 "%*sTYPE = %s ===> ",
53e06cf0 811 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
2814eb74 812 if (o->op_next)
b6f05621 813 PerlIO_printf(file,
147e3846 814 o->op_type == OP_NULL ? "(%" UVuf ")\n" : "%" UVuf "\n",
666ea192 815 sequence_num(o->op_next));
79072805 816 else
e75ab6ad 817 PerlIO_printf(file, "NULL\n");
11343788 818 if (o->op_targ) {
e15d5972 819 if (optype == OP_NULL) {
cea2e8a9 820 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
ae7d165c 821 }
8990e307 822 else
894356b3 823 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
8990e307 824 }
748a9306 825#ifdef DUMPADDR
147e3846
KW		 826 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%" UVxf " => 0x%" UVxf "\n",
827 (UV)o, (UV)o->op_next);
79072805 828#endif
a7fd8ef6 829
760f8c06
DM		 830 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
831 SV * const tmpsv = newSVpvs("");
832 switch (o->op_flags & OPf_WANT) {
833 case OPf_WANT_VOID:
834 sv_catpv(tmpsv, ",VOID");
835 break;
836 case OPf_WANT_SCALAR:
837 sv_catpv(tmpsv, ",SCALAR");
838 break;
839 case OPf_WANT_LIST:
840 sv_catpv(tmpsv, ",LIST");
841 break;
842 default:
843 sv_catpv(tmpsv, ",UNKNOWN");
844 break;
845 }
846 append_flags(tmpsv, o->op_flags, op_flags_names);
847 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
848 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
849 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
850 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
87b5a8b9 851 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB");
760f8c06
DM		 852 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
853 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
854 }
855
856 if (o->op_private) {
f3574cc6
DM		 857 U16 oppriv = o->op_private;
858 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
859 SV * tmpsv = NULL;
860
861 if (op_ix != -1) {
862 U16 stop = 0;
863 tmpsv = newSVpvs("");
864 for (; !stop; op_ix++) {
865 U16 entry = PL_op_private_bitdefs[op_ix];
866 U16 bit = (entry >> 2) & 7;
867 U16 ix = entry >> 5;
868
869 stop = (entry & 1);
870
871 if (entry & 2) {
872 /* bitfield */
873 I16 const *p = &PL_op_private_bitfields[ix];
874 U16 bitmin = (U16) *p++;
875 I16 label = *p++;
876 I16 enum_label;
877 U16 mask = 0;
878 U16 i;
879 U16 val;
880
881 for (i = bitmin; i<= bit; i++)
882 mask |= (1<<i);
883 bit = bitmin;
884 val = (oppriv & mask);
885
886 if ( label != -1
887 && PL_op_private_labels[label] == '-'
888 && PL_op_private_labels[label+1] == '\0'
889 )
890 /* display as raw number */
891 continue;
892
893 oppriv -= val;
894 val >>= bit;
895 enum_label = -1;
896 while (*p != -1) {
897 if (val == *p++) {
898 enum_label = *p;
899 break;
900 }
901 p++;
902 }
903 if (val == 0 && enum_label == -1)
904 /* don't display anonymous zero values */
905 continue;
906
907 sv_catpv(tmpsv, ",");
908 if (label != -1) {
909 sv_catpv(tmpsv, &PL_op_private_labels[label]);
910 sv_catpv(tmpsv, "=");
911 }
95268469 912 if (enum_label == -1)
147e3846 913 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val);
95268469
DM		 914 else
915 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
f3574cc6
DM		 916
917 }
918 else {
919 /* bit flag */
920 if ( oppriv & (1<<bit)
921 && !(PL_op_private_labels[ix] == '-'
922 && PL_op_private_labels[ix+1] == '\0'))
923 {
924 oppriv -= (1<<bit);
925 sv_catpv(tmpsv, ",");
926 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
927 }
760f8c06 928 }
760f8c06 929 }
f3574cc6
DM		 930 if (oppriv) {
931 sv_catpv(tmpsv, ",");
147e3846 932 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv);
760f8c06
DM		 933 }
934 }
f3574cc6 935 if (tmpsv && SvCUR(tmpsv)) {
760f8c06
DM		 936 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
937 } else
147e3846
KW		 938 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%" UVxf ")\n",
939 (UV)oppriv);
760f8c06
DM		 940 }
941
e15d5972 942 switch (optype) {
971a9dd3 943 case OP_AELEMFAST:
93a17b20 944 case OP_GVSV:
79072805 945 case OP_GV:
971a9dd3 946#ifdef USE_ITHREADS
c803eecc 947 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
971a9dd3 948#else
1640e9f0 949 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
38c076c7 950 if (cSVOPo->op_sv) {
0eb335df
BF		 951 STRLEN len;
952 const char * name;
953 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
954 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
159b6efe 955 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
0eb335df 956 name = SvPV_const(tmpsv, len);
8b6b16e7 957 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
0eb335df 958 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
38c076c7
DM		 959 }
960 else
961 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
378cc40b 962 }
971a9dd3 963#endif
79072805 964 break;
fedf30e1
DM		 965
966 case OP_MULTIDEREF:
967 {
968 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
969 UV i, count = items[-1].uv;
970
971 Perl_dump_indent(aTHX_ level, file, "ARGS = \n");
972 for (i=0; i < count; i++)
147e3846 973 Perl_dump_indent(aTHX_ level+1, file, "%" UVuf " => 0x%" UVxf "\n",
fedf30e1 974 i, items[i].uv);
1e9f2263 975 break;
fedf30e1
DM		 976 }
977
79072805 978 case OP_CONST:
996c9baa 979 case OP_HINTSEVAL:
f5d5a27c 980 case OP_METHOD_NAMED:
7d6c333c 981 case OP_METHOD_SUPER:
810bd8b7 982 case OP_METHOD_REDIR:
983 case OP_METHOD_REDIR_SUPER:
b6a15bc5
DM		 984#ifndef USE_ITHREADS
985 /* with ITHREADS, consts are stored in the pad, and the right pad
986 * may not be active here, so skip */
b46e009d 987 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
b6a15bc5 988#endif
79072805 989 break;
5e412b02
FC		 990 case OP_NULL:
991 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
992 break;
993 /* FALLTHROUGH */
93a17b20
LW		 994 case OP_NEXTSTATE:
995 case OP_DBSTATE:
57843af0 996 if (CopLINE(cCOPo))
147e3846 997 Perl_dump_indent(aTHX_ level, file, "LINE = %" UVuf "\n",
9d98dee5 998 (UV)CopLINE(cCOPo));
0eb335df
BF		 999 if (CopSTASHPV(cCOPo)) {
1000 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1001 HV *stash = CopSTASH(cCOPo);
1002 const char * const hvname = HvNAME_get(stash);
1003
ed094faf 1004 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
0eb335df
BF		 1005 generic_pv_escape(tmpsv, hvname,
1006 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1007 }
1008 if (CopLABEL(cCOPo)) {
1009 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1010 STRLEN label_len;
1011 U32 label_flags;
1012 const char *label = CopLABEL_len_flags(cCOPo,
1013 &label_len, &label_flags);
1014 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1015 generic_pv_escape( tmpsv, label, label_len,
1016 (label_flags & SVf_UTF8)));
1017 }
7fa99c80 1018 Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
947a9e0f 1019 (unsigned int)cCOPo->cop_seq);
79072805
LW		 1020 break;
1021 case OP_ENTERLOOP:
cea2e8a9 1022 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
11343788 1023 if (cLOOPo->op_redoop)
147e3846 1024 PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_redoop));
79072805 1025 else
3967c732 1026 PerlIO_printf(file, "DONE\n");
cea2e8a9 1027 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
11343788 1028 if (cLOOPo->op_nextop)
147e3846 1029 PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_nextop));
79072805 1030 else
3967c732 1031 PerlIO_printf(file, "DONE\n");
cea2e8a9 1032 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
11343788 1033 if (cLOOPo->op_lastop)
147e3846 1034 PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOOPo->op_lastop));
79072805 1035 else
3967c732 1036 PerlIO_printf(file, "DONE\n");
79072805
LW		 1037 break;
1038 case OP_COND_EXPR:
1a67a97c 1039 case OP_RANGE:
a0d0e21e 1040 case OP_MAPWHILE:
79072805
LW		 1041 case OP_GREPWHILE:
1042 case OP_OR:
1043 case OP_AND:
cea2e8a9 1044 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
11343788 1045 if (cLOGOPo->op_other)
147e3846 1046 PerlIO_printf(file, "%" UVuf "\n", sequence_num(cLOGOPo->op_other));
79072805 1047 else
3967c732 1048 PerlIO_printf(file, "DONE\n");
79072805 1049 break;
5012eebe 1050 case OP_SPLIT:
79072805 1051 case OP_MATCH:
8782bef2 1052 case OP_QR:
79072805 1053 case OP_SUBST:
3967c732 1054 do_pmop_dump(level, file, cPMOPo);
79072805 1055 break;
7934575e
GS		 1056 case OP_LEAVE:
1057 case OP_LEAVEEVAL:
1058 case OP_LEAVESUB:
1059 case OP_LEAVESUBLV:
1060 case OP_LEAVEWRITE:
1061 case OP_SCOPE:
1062 if (o->op_private & OPpREFCOUNTED)
147e3846 1063 Perl_dump_indent(aTHX_ level, file, "REFCNT = %" UVuf "\n", (UV)o->op_targ);
7934575e 1064 break;
a0d0e21e
LW		 1065 default:
1066 break;
79072805 1067 }
11343788 1068 if (o->op_flags & OPf_KIDS) {
79072805 1069 OP *kid;
e6dae479 1070 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3967c732 1071 do_op_dump(level, file, kid);
8d063cd8 1072 }
cea2e8a9 1073 Perl_dump_indent(aTHX_ level-1, file, "}\n");
3967c732
JD		 1074}
1075
36b1c95c
MH		 1076/*
1077=for apidoc op_dump
1078
1079Dumps the optree starting at OP C<o> to C<STDERR>.
1080
1081=cut
1082*/
1083
3967c732 1084void
6867be6d 1085Perl_op_dump(pTHX_ const OP *o)
3967c732 1086{
7918f24d 1087 PERL_ARGS_ASSERT_OP_DUMP;
3967c732 1088 do_op_dump(0, Perl_debug_log, o);
8d063cd8
LW		 1089}
1090
8adcabd8 1091void
864dbfa3 1092Perl_gv_dump(pTHX_ GV *gv)
378cc40b 1093{
0eb335df
BF		 1094 STRLEN len;
1095 const char* name;
1096 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1097
79072805 1098 if (!gv) {
760ac839 1099 PerlIO_printf(Perl_debug_log, "{}\n");
378cc40b
LW		 1100 return;
1101 }
8990e307 1102 sv = sv_newmortal();
760ac839 1103 PerlIO_printf(Perl_debug_log, "{\n");
bd61b366 1104 gv_fullname3(sv, gv, NULL);
0eb335df
BF		 1105 name = SvPV_const(sv, len);
1106 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1107 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
79072805 1108 if (gv != GvEGV(gv)) {
bd61b366 1109 gv_efullname3(sv, GvEGV(gv), NULL);
0eb335df
BF		 1110 name = SvPV_const(sv, len);
1111 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1112 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
8adcabd8 1113 }
38d7fd8b 1114 (void)PerlIO_putc(Perl_debug_log, '\n');
cea2e8a9 1115 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
8d063cd8
LW		 1116}
1117
14befaf4 1118
afe38520 1119/* map magic types to the symbolic names
14befaf4
DM		 1120 * (with the PERL_MAGIC_ prefixed stripped)
1121 */
1122
27da23d5 1123static const struct { const char type; const char *name; } magic_names[] = {
16bc0f48 1124#include "mg_names.inc"
516a5887 1125 /* this null string terminates the list */
b9ac451d 1126 { 0, NULL },
14befaf4
DM		 1127};
1128
8adcabd8 1129void
6867be6d 1130Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
8d063cd8 1131{
7918f24d
NC		 1132 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1133
3967c732 1134 for (; mg; mg = mg->mg_moremagic) {
b900a521 1135 Perl_dump_indent(aTHX_ level, file,
147e3846 1136 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg));
3967c732 1137 if (mg->mg_virtual) {
bfed75c6 1138 const MGVTBL * const v = mg->mg_virtual;
2d1f1fe5
NC		 1139 if (v >= PL_magic_vtables
1140 && v < PL_magic_vtables + magic_vtable_max) {
1141 const U32 i = v - PL_magic_vtables;
1142 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1143 }
3967c732 1144 else
147e3846
KW		 1145 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"
1146 UVxf "\n", PTR2UV(v));
3967c732
JD		 1147 }
1148 else
cea2e8a9 1149 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
8d063cd8 1150
3967c732 1151 if (mg->mg_private)
cea2e8a9 1152 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
3967c732 1153
14befaf4
DM		 1154 {
1155 int n;
c445ea15 1156 const char *name = NULL;
27da23d5 1157 for (n = 0; magic_names[n].name; n++) {
14befaf4
DM		 1158 if (mg->mg_type == magic_names[n].type) {
1159 name = magic_names[n].name;
1160 break;
1161 }
1162 }
1163 if (name)
1164 Perl_dump_indent(aTHX_ level, file,
1165 " MG_TYPE = PERL_MAGIC_%s\n", name);
1166 else
1167 Perl_dump_indent(aTHX_ level, file,
1168 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1169 }
3967c732
JD		 1170
1171 if (mg->mg_flags) {
cea2e8a9 1172 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
cb50f42d
YST		 1173 if (mg->mg_type == PERL_MAGIC_envelem &&
1174 mg->mg_flags & MGf_TAINTEDDIR)
cea2e8a9 1175 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
4c02285a
FR		 1176 if (mg->mg_type == PERL_MAGIC_regex_global &&
1177 mg->mg_flags & MGf_MINMATCH)
1178 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
3967c732 1179 if (mg->mg_flags & MGf_REFCOUNTED)
cea2e8a9 1180 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1181 if (mg->mg_flags & MGf_GSKIP)
cea2e8a9 1182 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
4c02285a
FR		 1183 if (mg->mg_flags & MGf_COPY)
1184 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1185 if (mg->mg_flags & MGf_DUP)
1186 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1187 if (mg->mg_flags & MGf_LOCAL)
1188 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
25fdce4a
FC		 1189 if (mg->mg_type == PERL_MAGIC_regex_global &&
1190 mg->mg_flags & MGf_BYTES)
1191 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
3967c732
JD		 1192 }
1193 if (mg->mg_obj) {
147e3846 1194 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n",
28d8d7f4
YO		 1195 PTR2UV(mg->mg_obj));
1196 if (mg->mg_type == PERL_MAGIC_qr) {
07bc277f 1197 REGEXP* const re = (REGEXP *)mg->mg_obj;
61f9802b 1198 SV * const dsv = sv_newmortal();
866c78d1 1199 const char * const s
4c02285a 1200 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
28d8d7f4 1201 60, NULL, NULL,
95b611b0 1202 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
3c8556c3 1203 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
28d8d7f4 1204 );
6483fb35 1205 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
147e3846 1206 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n",
07bc277f 1207 (IV)RX_REFCNT(re));
28d8d7f4
YO		 1208 }
1209 if (mg->mg_flags & MGf_REFCOUNTED)
3967c732
JD		 1210 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1211 }
1212 if (mg->mg_len)
894356b3 1213 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1214 if (mg->mg_ptr) {
147e3846 1215 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr));
3967c732 1216 if (mg->mg_len >= 0) {
7e8c5dac 1217 if (mg->mg_type != PERL_MAGIC_utf8) {
17605be7 1218 SV * const sv = newSVpvs("");
7e8c5dac 1219 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
17605be7 1220 SvREFCNT_dec_NN(sv);
7e8c5dac 1221 }
3967c732
JD		 1222 }
1223 else if (mg->mg_len == HEf_SVKEY) {
1224 PerlIO_puts(file, " => HEf_SVKEY\n");
ad64d0ec
NC		 1225 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1226 maxnest, dumpops, pvlim); /* MG is already +1 */
3967c732
JD		 1227 continue;
1228 }
866f9d6c 1229 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
3967c732 1230 else
866f9d6c
FC		 1231 PerlIO_puts(
1232 file,
1233 " ???? - " __FILE__
1234 " does not know how to handle this MG_LEN"
1235 );
38d7fd8b 1236 (void)PerlIO_putc(file, '\n');
3967c732 1237 }
7e8c5dac 1238 if (mg->mg_type == PERL_MAGIC_utf8) {
61f9802b 1239 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7e8c5dac
HS		 1240 if (cache) {
1241 IV i;
1242 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1243 Perl_dump_indent(aTHX_ level, file,
147e3846 1244 " %2" IVdf ": %" UVuf " -> %" UVuf "\n",
7e8c5dac
HS		 1245 i,
1246 (UV)cache[i * 2],
1247 (UV)cache[i * 2 + 1]);
1248 }
1249 }
378cc40b 1250 }
3967c732
JD		 1251}
1252
1253void
6867be6d 1254Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1255{
b9ac451d 1256 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732
JD		 1257}
1258
1259void
e1ec3a88 1260Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1261{
bfcb3514 1262 const char *hvname;
7918f24d
NC		 1263
1264 PERL_ARGS_ASSERT_DO_HV_DUMP;
1265
147e3846 1266 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
bfcb3514 1267 if (sv && (hvname = HvNAME_get(sv)))
d7d51f4b
YO		 1268 {
1269 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1270 name which quite legally could contain insane things like tabs, newlines, nulls or
1271 other scary crap - this should produce sane results - except maybe for unicode package
1272 names - but we will wait for someone to file a bug on that - demerphq */
0eb335df
BF		 1273 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1274 PerlIO_printf(file, "\t\"%s\"\n",
1275 generic_pv_escape( tmpsv, hvname,
1276 HvNAMELEN(sv), HvNAMEUTF8(sv)));
d7d51f4b 1277 }
79072805 1278 else
38d7fd8b 1279 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1280}
1281
1282void
e1ec3a88 1283Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1284{
7918f24d
NC		 1285 PERL_ARGS_ASSERT_DO_GV_DUMP;
1286
147e3846 1287 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
0eb335df
BF		 1288 if (sv && GvNAME(sv)) {
1289 SV * const tmpsv = newSVpvs("");
1290 PerlIO_printf(file, "\t\"%s\"\n",
1291 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1292 }
c90c0ff4 1293 else
38d7fd8b 1294 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1295}
1296
1297void
e1ec3a88 1298Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1299{
7918f24d
NC		 1300 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1301
147e3846 1302 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv));
3967c732 1303 if (sv && GvNAME(sv)) {
0eb335df 1304 SV *tmp = newSVpvs_flags("", SVs_TEMP);
bfcb3514 1305 const char *hvname;
0eb335df
BF		 1306 HV * const stash = GvSTASH(sv);
1307 PerlIO_printf(file, "\t");
1308 /* TODO might have an extra \" here */
1309 if (stash && (hvname = HvNAME_get(stash))) {
1310 PerlIO_printf(file, "\"%s\" :: \"",
1311 generic_pv_escape(tmp, hvname,
1312 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1313 }
1314 PerlIO_printf(file, "%s\"\n",
1315 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
8d063cd8 1316 }
3967c732 1317 else
38d7fd8b 1318 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1319}
1320
a0c2f4dd
NC		 1321const struct flag_to_name first_sv_flags_names[] = {
1322 {SVs_TEMP, "TEMP,"},
1323 {SVs_OBJECT, "OBJECT,"},
1324 {SVs_GMG, "GMG,"},
1325 {SVs_SMG, "SMG,"},
1326 {SVs_RMG, "RMG,"},
1327 {SVf_IOK, "IOK,"},
1328 {SVf_NOK, "NOK,"},
1329 {SVf_POK, "POK,"}
1330};
1331
1332const struct flag_to_name second_sv_flags_names[] = {
1333 {SVf_OOK, "OOK,"},
1334 {SVf_FAKE, "FAKE,"},
1335 {SVf_READONLY, "READONLY,"},
fd01b4b7 1336 {SVf_PROTECT, "PROTECT,"},
a0c2f4dd 1337 {SVf_BREAK, "BREAK,"},
a0c2f4dd
NC		 1338 {SVp_IOK, "pIOK,"},
1339 {SVp_NOK, "pNOK,"},
1340 {SVp_POK, "pPOK,"}
1341};
1342
ae1f06a1
NC		 1343const struct flag_to_name cv_flags_names[] = {
1344 {CVf_ANON, "ANON,"},
1345 {CVf_UNIQUE, "UNIQUE,"},
1346 {CVf_CLONE, "CLONE,"},
1347 {CVf_CLONED, "CLONED,"},
1348 {CVf_CONST, "CONST,"},
1349 {CVf_NODEBUG, "NODEBUG,"},
1350 {CVf_LVALUE, "LVALUE,"},
1351 {CVf_METHOD, "METHOD,"},
cfc1e951 1352 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1353 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1354 {CVf_DYNFILE, "DYNFILE,"},
8fa6a409 1355 {CVf_AUTOLOAD, "AUTOLOAD,"},
e4555ecf 1356 {CVf_HASEVAL, "HASEVAL,"},
bfbc3ad9 1357 {CVf_SLABBED, "SLABBED,"},
bf9a4d2d 1358 {CVf_NAMED, "NAMED,"},
82487b59 1359 {CVf_LEXICAL, "LEXICAL,"},
31d45e0c 1360 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC		 1361};
1362
1363const struct flag_to_name hv_flags_names[] = {
1364 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1365 {SVphv_LAZYDEL, "LAZYDEL,"},
1366 {SVphv_HASKFLAGS, "HASKFLAGS,"},
45eaf8af 1367 {SVf_AMAGIC, "OVERLOAD,"},
ae1f06a1
NC		 1368 {SVphv_CLONEABLE, "CLONEABLE,"}
1369};
1370
1371const struct flag_to_name gp_flags_names[] = {
1372 {GVf_INTRO, "INTRO,"},
1373 {GVf_MULTI, "MULTI,"},
1374 {GVf_ASSUMECV, "ASSUMECV,"},
ae1f06a1
NC		 1375};
1376
1377const struct flag_to_name gp_flags_imported_names[] = {
1378 {GVf_IMPORTED_SV, " SV"},
1379 {GVf_IMPORTED_AV, " AV"},
1380 {GVf_IMPORTED_HV, " HV"},
1381 {GVf_IMPORTED_CV, " CV"},
1382};
1383
0d331aaf
YO		 1384/* NOTE: this structure is mostly duplicative of one generated by
1385 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1386 * the two. - Yves */
e3e400ec 1387const struct flag_to_name regexp_extflags_names[] = {
d63e6659
DM		 1388 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1389 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1390 {RXf_PMf_FOLD, "PMf_FOLD,"},
1391 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
334afb3e 1392 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
d63e6659 1393 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
41d7c59e 1394 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
8e1490ee 1395 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
dbc200c5 1396 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
d63e6659 1397 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
d63e6659
DM		 1398 {RXf_CHECK_ALL, "CHECK_ALL,"},
1399 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1400 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1401 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1402 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
dbc200c5 1403 {RXf_SPLIT, "SPLIT,"},
d63e6659
DM		 1404 {RXf_COPY_DONE, "COPY_DONE,"},
1405 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1406 {RXf_TAINTED, "TAINTED,"},
1407 {RXf_START_ONLY, "START_ONLY,"},
dbc200c5 1408 {RXf_SKIPWHITE, "SKIPWHITE,"},
d63e6659
DM		 1409 {RXf_WHITE, "WHITE,"},
1410 {RXf_NULL, "NULL,"},
1411};
1412
0d331aaf
YO		 1413/* NOTE: this structure is mostly duplicative of one generated by
1414 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1415 * the two. - Yves */
e3e400ec
YO		 1416const struct flag_to_name regexp_core_intflags_names[] = {
1417 {PREGf_SKIP, "SKIP,"},
0d331aaf
YO		 1418 {PREGf_IMPLICIT, "IMPLICIT,"},
1419 {PREGf_NAUGHTY, "NAUGHTY,"},
e3e400ec
YO		 1420 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1421 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
0d331aaf 1422 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
e3e400ec 1423 {PREGf_NOSCAN, "NOSCAN,"},
58430ea8
YO		 1424 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1425 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
8e1490ee
YO		 1426 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1427 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1428 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
e3e400ec
YO		 1429};
1430
c24d0595
DM		 1431/* Perl_do_sv_dump():
1432 *
1433 * level: amount to indent the output
1434 * sv: the object to dump
1435 * nest: the current level of recursion
1436 * maxnest: the maximum allowed level of recursion
1437 * dumpops: if true, also dump the ops associated with a CV
1438 * pvlim: limit on the length of any strings that are output
1439 * */
1440
3967c732 1441void
864dbfa3 1442Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1443{
cea89e20 1444 SV *d;
e1ec3a88 1445 const char *s;
3967c732
JD		 1446 U32 flags;
1447 U32 type;
1448
7918f24d
NC		 1449 PERL_ARGS_ASSERT_DO_SV_DUMP;
1450
3967c732 1451 if (!sv) {
cea2e8a9 1452 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1453 return;
378cc40b 1454 }
2ef28da1 1455
3967c732
JD		 1456 flags = SvFLAGS(sv);
1457 type = SvTYPE(sv);
79072805 1458
e0bbf362
DM		 1459 /* process general SV flags */
1460
cea89e20 1461 d = Perl_newSVpvf(aTHX_
147e3846 1462 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (",
56431972 1463 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS		 1464 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1465 (int)(PL_dumpindent*level), "");
8d063cd8 1466
0f94cb1f 1467 if ((flags & SVs_PADSTALE))
9a214eec 1468 sv_catpv(d, "PADSTALE,");
0f94cb1f 1469 if ((flags & SVs_PADTMP))
9a214eec 1470 sv_catpv(d, "PADTMP,");
a0c2f4dd 1471 append_flags(d, flags, first_sv_flags_names);
810b8aa5
GS		 1472 if (flags & SVf_ROK) {
1473 sv_catpv(d, "ROK,");
1474 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1475 }
45eaf8af 1476 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
a0c2f4dd 1477 append_flags(d, flags, second_sv_flags_names);
7db6405c
FC		 1478 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1479 && type != SVt_PVAV) {
1ccdb730
NC		 1480 if (SvPCS_IMPORTED(sv))
1481 sv_catpv(d, "PCS_IMPORTED,");
1482 else
9660f481 1483 sv_catpv(d, "SCREAM,");
1ccdb730 1484 }
3967c732 1485
e0bbf362
DM		 1486 /* process type-specific SV flags */
1487
3967c732
JD		 1488 switch (type) {
1489 case SVt_PVCV:
1490 case SVt_PVFM:
ae1f06a1 1491 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD		 1492 break;
1493 case SVt_PVHV:
ae1f06a1 1494 append_flags(d, flags, hv_flags_names);
3967c732 1495 break;
926fc7b6
DM		 1496 case SVt_PVGV:
1497 case SVt_PVLV:
1498 if (isGV_with_GP(sv)) {
ae1f06a1 1499 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1500 }
926fc7b6 1501 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD		 1502 sv_catpv(d, "IMPORT");
1503 if (GvIMPORTED(sv) == GVf_IMPORTED)
1504 sv_catpv(d, "ALL,");
1505 else {
1506 sv_catpv(d, "(");
ae1f06a1 1507 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
3967c732
JD		 1508 sv_catpv(d, " ),");
1509 }
1510 }
924ba076 1511 /* FALLTHROUGH */
a5c7cb08 1512 case SVt_PVMG:
25da4f38 1513 default:
69c678eb 1514 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1515 break;
a5c7cb08 1516
11ca45c0
NC		 1517 case SVt_PVAV:
1518 break;
3967c732 1519 }
86f0d186
NC		 1520 /* SVphv_SHAREKEYS is also 0x20000000 */
1521 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1522 sv_catpv(d, "UTF8");
3967c732 1523
b162af07
SP		 1524 if (*(SvEND(d) - 1) == ',') {
1525 SvCUR_set(d, SvCUR(d) - 1);
1526 SvPVX(d)[SvCUR(d)] = '\0';
1527 }
3967c732 1528 sv_catpv(d, ")");
b15aece3 1529 s = SvPVX_const(d);
3967c732 1530
e0bbf362
DM		 1531 /* dump initial SV details */
1532
fd0854ff 1533#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1534 Perl_dump_indent(aTHX_ level, file,
147e3846 1535 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n",
fd0854ff
DM		 1536 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1537 sv->sv_debug_line,
1538 sv->sv_debug_inpad ? "for" : "by",
1539 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1540 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM		 1541 sv->sv_debug_serial
1542 );
fd0854ff 1543#endif
cea2e8a9 1544 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM		 1545
1546 /* Dump SV type */
1547
5357ca29
NC		 1548 if (type < SVt_LAST) {
1549 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1550
1551 if (type == SVt_NULL) {
5f954473 1552 SvREFCNT_dec_NN(d);
5357ca29
NC		 1553 return;
1554 }
1555 } else {
147e3846 1556 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s);
5f954473 1557 SvREFCNT_dec_NN(d);
3967c732
JD		 1558 return;
1559 }
e0bbf362
DM		 1560
1561 /* Dump general SV fields */
1562
27bd069f 1563 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC		 1564 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1565 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1566 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1567 if (SvIsUV(sv)
765f542d 1568 )
147e3846 1569 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv));
cf2093f6 1570 else
147e3846 1571 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv));
38d7fd8b 1572 (void)PerlIO_putc(file, '\n');
3967c732 1573 }
e0bbf362 1574
0f94cb1f 1575 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1576 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1577 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1578 || type == SVt_NV) {
67d796ae 1579 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
88cb8500 1580 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
67d796ae 1581 RESTORE_LC_NUMERIC_UNDERLYING();
3967c732 1582 }
e0bbf362 1583
3967c732 1584 if (SvROK(sv)) {
147e3846
KW		 1585 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n",
1586 PTR2UV(SvRV(sv)));
3967c732
JD		 1587 if (nest < maxnest)
1588 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1589 }
e0bbf362 1590
cea89e20 1591 if (type < SVt_PV) {
5f954473 1592 SvREFCNT_dec_NN(d);
3967c732 1593 return;
cea89e20 1594 }
e0bbf362 1595
5a3c7349
FC		 1596 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1597 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
8d919b0a
FC		 1598 const bool re = isREGEXP(sv);
1599 const char * const ptr =
1600 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1601 if (ptr) {
69240efd 1602 STRLEN delta;
7a4bba22 1603 if (SvOOK(sv)) {
69240efd 1604 SvOOK_offset(sv, delta);
147e3846 1605 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n",
5186cc12 1606 (UV) delta);
69240efd
NC		 1607 } else {
1608 delta = 0;
7a4bba22 1609 }
147e3846
KW		 1610 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ",
1611 PTR2UV(ptr));
7a4bba22
NC		 1612 if (SvOOK(sv)) {
1613 PerlIO_printf(file, "( %s . ) ",
8d919b0a 1614 pv_display(d, ptr - delta, delta, 0,
7a4bba22
NC		 1615 pvlim));
1616 }
ad3f05ad
KW		 1617 if (type == SVt_INVLIST) {
1618 PerlIO_printf(file, "\n");
1619 /* 4 blanks indents 2 beyond the PV, etc */
1620 _invlist_dump(file, level, " ", sv);
1621 }
1622 else {
685bfc3c
KW		 1623 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1624 re ? 0 : SvLEN(sv),
1625 pvlim));
1626 if (SvUTF8(sv)) /* the 6? \x{....} */
1627 PerlIO_printf(file, " [UTF8 \"%s\"]",
1628 sv_uni_display(d, sv, 6 * SvCUR(sv),
1629 UNI_DISPLAY_QQ));
1630 PerlIO_printf(file, "\n");
ad3f05ad 1631 }
147e3846 1632 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv));
8d919b0a 1633 if (!re)
147e3846 1634 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n",
8d919b0a 1635 (IV)SvLEN(sv));
93c10d60 1636#ifdef PERL_COPY_ON_WRITE
db2c6cb3
FC		 1637 if (SvIsCOW(sv) && SvLEN(sv))
1638 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1639 CowREFCNT(sv));
1640#endif
3967c732
JD		 1641 }
1642 else
cea2e8a9 1643 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1644 }
e0bbf362 1645
3967c732 1646 if (type >= SVt_PVMG) {
0f94cb1f 1647 if (SvMAGIC(sv))
8530ff28 1648 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
3967c732
JD		 1649 if (SvSTASH(sv))
1650 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC		 1651
1652 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
147e3846
KW		 1653 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n",
1654 (IV)BmUSEFUL(sv));
c13a5c80 1655 }
3967c732 1656 }
e0bbf362
DM		 1657
1658 /* Dump type-specific SV fields */
1659
3967c732 1660 switch (type) {
3967c732 1661 case SVt_PVAV:
147e3846
KW		 1662 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf,
1663 PTR2UV(AvARRAY(sv)));
3967c732 1664 if (AvARRAY(sv) != AvALLOC(sv)) {
147e3846
KW		 1665 PerlIO_printf(file, " (offset=%" IVdf ")\n",
1666 (IV)(AvARRAY(sv) - AvALLOC(sv)));
1667 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n",
1668 PTR2UV(AvALLOC(sv)));
3967c732
JD		 1669 }
1670 else
38d7fd8b 1671 (void)PerlIO_putc(file, '\n');
147e3846
KW		 1672 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n",
1673 (IV)AvFILLp(sv));
1674 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1675 (IV)AvMAX(sv));
ed0faf2e 1676 SvPVCLEAR(d);
11ca45c0
NC		 1677 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1678 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP		 1679 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1680 SvCUR(d) ? SvPVX_const(d) + 1 : "");
476fafda 1681 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) {
c70927a6 1682 SSize_t count;
476fafda
DM		 1683 SV **svp = AvARRAY(MUTABLE_AV(sv));
1684 for (count = 0;
1685 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest;
1686 count++, svp++)
1687 {
1688 SV* const elt = *svp;
147e3846
KW		 1689 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n",
1690 (IV)count);
476fafda 1691 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
3967c732
JD		 1692 }
1693 }
1694 break;
5d27ee4a
DD		 1695 case SVt_PVHV: {
1696 U32 usedkeys;
0c22a733
DM		 1697 if (SvOOK(sv)) {
1698 struct xpvhv_aux *const aux = HvAUX(sv);
147e3846 1699 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n",
0c22a733
DM		 1700 (UV)aux->xhv_aux_flags);
1701 }
147e3846 1702 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
5d27ee4a
DD		 1703 usedkeys = HvUSEDKEYS(sv);
1704 if (HvARRAY(sv) && usedkeys) {
3967c732
JD		 1705 /* Show distribution of HEs in the ARRAY */
1706 int freq[200];
c3caa5c3 1707#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
3967c732
JD		 1708 int i;
1709 int max = 0;
5d27ee4a 1710 U32 pow2 = 2, keys = usedkeys;
65202027 1711 NV theoret, sum = 0;
3967c732
JD		 1712
1713 PerlIO_printf(file, " (");
1714 Zero(freq, FREQ_MAX + 1, int);
eb160463 1715 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL		 1716 HE* h;
1717 int count = 0;
3967c732
JD		 1718 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1719 count++;
1720 if (count > FREQ_MAX)
1721 count = FREQ_MAX;
1722 freq[count]++;
1723 if (max < count)
1724 max = count;
1725 }
1726 for (i = 0; i <= max; i++) {
1727 if (freq[i]) {
1728 PerlIO_printf(file, "%d%s:%d", i,
1729 (i == FREQ_MAX) ? "+" : "",
1730 freq[i]);
1731 if (i != max)
1732 PerlIO_printf(file, ", ");
1733 }
1734 }
38d7fd8b 1735 (void)PerlIO_putc(file, ')');
b8fa94d8
MG		 1736 /* The "quality" of a hash is defined as the total number of
1737 comparisons needed to access every element once, relative
1738 to the expected number needed for a random hash.
1739
1740 The total number of comparisons is equal to the sum of
e76cd0fa
AMS		 1741 the squares of the number of entries in each bucket.
1742 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG		 1743 value is
1744 n + n(n-1)/2k
1745 */
1746
3967c732
JD		 1747 for (i = max; i > 0; i--) { /* Precision: count down. */
1748 sum += freq[i] * i * i;
1749 }
155aba94 1750 while ((keys = keys >> 1))
3967c732 1751 pow2 = pow2 << 1;
5d27ee4a 1752 theoret = usedkeys;
b8fa94d8 1753 theoret += theoret * (theoret-1)/pow2;
38d7fd8b 1754 (void)PerlIO_putc(file, '\n');
147e3846
KW		 1755 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"
1756 NVff "%%", theoret/sum*100);
3967c732 1757 }
38d7fd8b 1758 (void)PerlIO_putc(file, '\n');
147e3846
KW		 1759 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n",
1760 (IV)usedkeys);
9faf471a
NC		 1761 {
1762 STRLEN count = 0;
1763 HE **ents = HvARRAY(sv);
1764
1765 if (ents) {
1766 HE *const *const last = ents + HvMAX(sv);
1767 count = last + 1 - ents;
1768
1769 do {
1770 if (!*ents)
1771 --count;
1772 } while (++ents <= last);
1773 }
1774
147e3846 1775 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n",
8bf4c401 1776 (UV)count);
9faf471a 1777 }
147e3846
KW		 1778 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n",
1779 (IV)HvMAX(sv));
e1a7ec8d 1780 if (SvOOK(sv)) {
147e3846
KW		 1781 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n",
1782 (IV)HvRITER_get(sv));
1783 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n",
1784 PTR2UV(HvEITER_get(sv)));
6a5b4183 1785#ifdef PERL_HASH_RANDOMIZE_KEYS
147e3846
KW		 1786 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf,
1787 (UV)HvRAND_get(sv));
e1a7ec8d 1788 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
147e3846
KW		 1789 PerlIO_printf(file, " (LAST = 0x%" UVxf ")",
1790 (UV)HvLASTRAND_get(sv));
e1a7ec8d 1791 }
6a5b4183 1792#endif
38d7fd8b 1793 (void)PerlIO_putc(file, '\n');
e1a7ec8d 1794 }
8d2f4536 1795 {
b9ac451d 1796 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536 1797 if (mg && mg->mg_obj) {
147e3846 1798 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj));
8d2f4536
NC		 1799 }
1800 }
bfcb3514 1801 {
b9ac451d 1802 const char * const hvname = HvNAME_get(sv);
0eb335df
BF		 1803 if (hvname) {
1804 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1805 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1806 generic_pv_escape( tmpsv, hvname,
1807 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1808 }
bfcb3514 1809 }
86f55936 1810 if (SvOOK(sv)) {
ad64d0ec 1811 AV * const backrefs
85fbaab2 1812 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 1813 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC		 1814 if (HvAUX(sv)->xhv_name_count)
1815 Perl_dump_indent(aTHX_
147e3846 1816 level, file, " NAMECOUNT = %" IVdf "\n",
7afc2217 1817 (IV)HvAUX(sv)->xhv_name_count
67e04715 1818 );
15d9236d 1819 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC		 1820 const I32 count = HvAUX(sv)->xhv_name_count;
1821 if (count) {
1822 SV * const names = newSVpvs_flags("", SVs_TEMP);
1823 /* The starting point is the first element if count is
1824 positive and the second element if count is negative. */
1825 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1826 + (count < 0 ? 1 : 0);
1827 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1828 + (count < 0 ? -count : count);
1829 while (hekp < endp) {
8e5993c4 1830 if (*hekp) {
0eb335df
BF		 1831 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1832 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1833 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
ec3405c8
NC		 1834 } else {
1835 /* This should never happen. */
1836 sv_catpvs(names, ", (null)");
67e04715 1837 }
ec3405c8
NC		 1838 ++hekp;
1839 }
67e04715
FC		 1840 Perl_dump_indent(aTHX_
1841 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1842 );
1843 }
0eb335df
BF		 1844 else {
1845 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1846 const char *const hvename = HvENAME_get(sv);
67e04715 1847 Perl_dump_indent(aTHX_
0eb335df
BF		 1848 level, file, " ENAME = \"%s\"\n",
1849 generic_pv_escape(tmp, hvename,
1850 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1851 }
67e04715 1852 }
86f55936 1853 if (backrefs) {
147e3846 1854 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n",
86f55936 1855 PTR2UV(backrefs));
ad64d0ec 1856 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC		 1857 dumpops, pvlim);
1858 }
7d88e6c4 1859 if (meta) {
0eb335df 1860 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
147e3846
KW		 1861 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"
1862 UVxf ")\n",
0eb335df
BF		 1863 generic_pv_escape( tmpsv, meta->mro_which->name,
1864 meta->mro_which->length,
1865 (meta->mro_which->kflags & HVhek_UTF8)),
7d88e6c4 1866 PTR2UV(meta->mro_which));
147e3846
KW		 1867 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"
1868 UVxf "\n",
7d88e6c4 1869 (UV)meta->cache_gen);
147e3846 1870 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n",
7d88e6c4
NC		 1871 (UV)meta->pkg_gen);
1872 if (meta->mro_linear_all) {
147e3846
KW		 1873 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"
1874 UVxf "\n",
7d88e6c4
NC		 1875 PTR2UV(meta->mro_linear_all));
1876 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1877 dumpops, pvlim);
1878 }
1879 if (meta->mro_linear_current) {
147e3846
KW		 1880 Perl_dump_indent(aTHX_ level, file,
1881 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n",
7d88e6c4
NC		 1882 PTR2UV(meta->mro_linear_current));
1883 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1884 dumpops, pvlim);
1885 }
1886 if (meta->mro_nextmethod) {
147e3846
KW		 1887 Perl_dump_indent(aTHX_ level, file,
1888 " MRO_NEXTMETHOD = 0x%" UVxf "\n",
7d88e6c4
NC		 1889 PTR2UV(meta->mro_nextmethod));
1890 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1891 dumpops, pvlim);
1892 }
1893 if (meta->isa) {
147e3846 1894 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n",
7d88e6c4
NC		 1895 PTR2UV(meta->isa));
1896 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1897 dumpops, pvlim);
1898 }
1899 }
86f55936 1900 }
b5698553 1901 if (nest < maxnest) {
cbab3169 1902 HV * const hv = MUTABLE_HV(sv);
b5698553
TH		 1903 STRLEN i;
1904 HE *he;
cbab3169 1905
b5698553
TH		 1906 if (HvARRAY(hv)) {
1907 int count = maxnest - nest;
1908 for (i=0; i <= HvMAX(hv); i++) {
1909 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1910 U32 hash;
1911 SV * keysv;
1912 const char * keypv;
1913 SV * elt;
7dc86639 1914 STRLEN len;
b5698553
TH		 1915
1916 if (count-- <= 0) goto DONEHV;
1917
1918 hash = HeHASH(he);
1919 keysv = hv_iterkeysv(he);
1920 keypv = SvPV_const(keysv, len);
1921 elt = HeVAL(he);
cbab3169 1922
7dc86639
YO		 1923 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1924 if (SvUTF8(keysv))
1925 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH		 1926 if (HvEITER_get(hv) == he)
1927 PerlIO_printf(file, "[CURRENT] ");
147e3846 1928 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash);
7dc86639
YO		 1929 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1930 }
b5698553
TH		 1931 }
1932 DONEHV:;
1933 }
3967c732
JD		 1934 }
1935 break;
5d27ee4a 1936 } /* case SVt_PVHV */
e0bbf362 1937
3967c732 1938 case SVt_PVCV:
8fa6a409 1939 if (CvAUTOLOAD(sv)) {
0eb335df
BF		 1940 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1941 STRLEN len;
8fa6a409 1942 const char *const name = SvPV_const(sv, len);
0eb335df
BF		 1943 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1944 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
8fa6a409
FC		 1945 }
1946 if (SvPOK(sv)) {
0eb335df
BF		 1947 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1948 const char *const proto = CvPROTO(sv);
1949 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1950 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1951 SvUTF8(sv)));
cbf82dd0 1952 }
924ba076 1953 /* FALLTHROUGH */
3967c732
JD		 1954 case SVt_PVFM:
1955 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC		 1956 if (!CvISXSUB(sv)) {
1957 if (CvSTART(sv)) {
27604593
DM		 1958 if (CvSLABBED(sv))
1959 Perl_dump_indent(aTHX_ level, file,
147e3846 1960 " SLAB = 0x%" UVxf "\n",
27604593
DM		 1961 PTR2UV(CvSTART(sv)));
1962 else
1963 Perl_dump_indent(aTHX_ level, file,
147e3846 1964 " START = 0x%" UVxf " ===> %" IVdf "\n",
d04ba589
NC		 1965 PTR2UV(CvSTART(sv)),
1966 (IV)sequence_num(CvSTART(sv)));
1967 }
147e3846 1968 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n",
d04ba589
NC		 1969 PTR2UV(CvROOT(sv)));
1970 if (CvROOT(sv) && dumpops) {
1971 do_op_dump(level+1, file, CvROOT(sv));
1972 }
1973 } else {
126f53f3 1974 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 1975
147e3846 1976 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv)));
b1886099
NC		 1977
1978 if (constant) {
147e3846 1979 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf
b1886099
NC		 1980 " (CONST SV)\n",
1981 PTR2UV(CvXSUBANY(sv).any_ptr));
1982 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1983 pvlim);
1984 } else {
147e3846 1985 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n",
b1886099
NC		 1986 (IV)CvXSUBANY(sv).any_i32);
1987 }
1988 }
3610c89f
FC		 1989 if (CvNAMED(sv))
1990 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1991 HEK_KEY(CvNAME_HEK((CV *)sv)));
1992 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1993 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
147e3846
KW		 1994 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"
1995 IVdf "\n", (IV)CvDEPTH(sv));
1996 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n",
1997 (UV)CvFLAGS(sv));
1998 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv));
eacbb379 1999 if (!CvISXSUB(sv)) {
147e3846 2000 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv)));
eacbb379
DD		 2001 if (nest < maxnest) {
2002 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
2003 }
3967c732 2004 }
eacbb379 2005 else
db6e00bd 2006 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
3967c732 2007 {
b9ac451d 2008 const CV * const outside = CvOUTSIDE(sv);
147e3846 2009 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n",
57def98f 2010 PTR2UV(outside),
cf2093f6
JH		 2011 (!outside ? "null"
2012 : CvANON(outside) ? "ANON"
2013 : (outside == PL_main_cv) ? "MAIN"
2014 : CvUNIQUE(outside) ? "UNIQUE"
b24fda9d
BF		 2015 : CvGV(outside) ?
2016 generic_pv_escape(
2017 newSVpvs_flags("", SVs_TEMP),
2018 GvNAME(CvGV(outside)),
2019 GvNAMELEN(CvGV(outside)),
2020 GvNAMEUTF8(CvGV(outside)))
2021 : "UNDEFINED"));
3967c732 2022 }
704b97aa
FC		 2023 if (CvOUTSIDE(sv)
2024 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
ad64d0ec 2025 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2026 break;
e0bbf362 2027
926fc7b6
DM		 2028 case SVt_PVGV:
2029 case SVt_PVLV:
b9ac451d
AL		 2030 if (type == SVt_PVLV) {
2031 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
147e3846
KW		 2032 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv));
2033 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv));
2034 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv)));
2035 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv));
305b8651 2036 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
b9ac451d
AL		 2037 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2038 dumpops, pvlim);
2039 }
8d919b0a 2040 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM		 2041 if (!isGV_with_GP(sv))
2042 break;
0eb335df
BF		 2043 {
2044 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2045 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2046 generic_pv_escape(tmpsv, GvNAME(sv),
2047 GvNAMELEN(sv),
2048 GvNAMEUTF8(sv)));
2049 }
147e3846 2050 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv));
3967c732 2051 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
147e3846
KW		 2052 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv));
2053 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv)));
f472eb5c
GS		 2054 if (!GvGP(sv))
2055 break;
147e3846
KW		 2056 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv)));
2057 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv));
2058 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv)));
2059 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv)));
2060 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv)));
2061 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv)));
2062 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv)));
2063 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv));
2064 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf
008009b0
FC		 2065 " (%s)\n",
2066 (UV)GvGPFLAGS(sv),
71afaece 2067 "");
147e3846 2068 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv));
b195d487 2069 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
3967c732
JD		 2070 do_gv_dump (level, file, " EGV", GvEGV(sv));
2071 break;
2072 case SVt_PVIO:
147e3846
KW		 2073 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv)));
2074 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv)));
2075 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv)));
2076 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv));
2077 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv));
2078 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv));
2079 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv));
27533608 2080 if (IoTOP_NAME(sv))
cea2e8a9 2081 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC		 2082 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2083 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2084 else {
147e3846 2085 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n",
9ba1f565 2086 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC		 2087 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2088 maxnest, dumpops, pvlim);
9ba1f565
NC		 2089 }
2090 /* Source filters hide things that are not GVs in these three, so let's
2091 be careful out there. */
27533608 2092 if (IoFMT_NAME(sv))
cea2e8a9 2093 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC		 2094 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2095 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2096 else {
147e3846 2097 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n",
9ba1f565 2098 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC		 2099 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2100 maxnest, dumpops, pvlim);
9ba1f565 2101 }
27533608 2102 if (IoBOTTOM_NAME(sv))
cea2e8a9 2103 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC		 2104 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2105 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2106 else {
147e3846 2107 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n",
9ba1f565 2108 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC		 2109 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2110 maxnest, dumpops, pvlim);
9ba1f565 2111 }
27533608 2112 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2113 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2114 else
cea2e8a9 2115 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
147e3846 2116 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv));
3967c732 2117 break;
206ee256 2118 case SVt_REGEXP:
8d919b0a 2119 dumpregexp:
d63e6659 2120 {
8d919b0a 2121 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO		 2122
2123#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2124 sv_setpv(d,""); \
e3e400ec 2125 append_flags(d, flags, names); \
ec16d31f
YO		 2126 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2127 SvCUR_set(d, SvCUR(d) - 1); \
2128 SvPVX(d)[SvCUR(d)] = '\0'; \
2129 } \
2130} STMT_END
e3e400ec 2131 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
147e3846 2132 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO		 2133 (UV)(r->compflags), SvPVX_const(d));
2134
e3e400ec 2135 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
147e3846 2136 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n",
dbc200c5
YO		 2137 (UV)(r->extflags), SvPVX_const(d));
2138
147e3846 2139 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n",
e3e400ec
YO		 2140 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2141 if (r->engine == &PL_core_reg_engine) {
2142 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
147e3846 2143 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n",
e3e400ec
YO		 2144 (UV)(r->intflags), SvPVX_const(d));
2145 } else {
147e3846 2146 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n",
d63e6659 2147 (UV)(r->intflags));
e3e400ec
YO		 2148 }
2149#undef SV_SET_STRINGIFY_REGEXP_FLAGS
147e3846 2150 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n",
d63e6659 2151 (UV)(r->nparens));
147e3846 2152 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n",
d63e6659 2153 (UV)(r->lastparen));
147e3846 2154 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n",
d63e6659 2155 (UV)(r->lastcloseparen));
147e3846 2156 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n",
d63e6659 2157 (IV)(r->minlen));
147e3846 2158 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n",
d63e6659 2159 (IV)(r->minlenret));
147e3846 2160 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n",
d63e6659 2161 (UV)(r->gofs));
147e3846 2162 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n",
d63e6659 2163 (UV)(r->pre_prefix));
147e3846 2164 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n",
d63e6659 2165 (IV)(r->sublen));
147e3846 2166 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n",
6502e081 2167 (IV)(r->suboffset));
147e3846 2168 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n",
6502e081 2169 (IV)(r->subcoffset));
d63e6659 2170 if (r->subbeg)
147e3846 2171 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n",
d63e6659
DM		 2172 PTR2UV(r->subbeg),
2173 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2174 else
2175 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
147e3846 2176 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n",
d63e6659 2177 PTR2UV(r->mother_re));
01ffd0f1
FC		 2178 if (nest < maxnest && r->mother_re)
2179 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2180 maxnest, dumpops, pvlim);
147e3846 2181 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n",
d63e6659 2182 PTR2UV(r->paren_names));
147e3846 2183 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n",
d63e6659 2184 PTR2UV(r->substrs));
147e3846 2185 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n",
d63e6659 2186 PTR2UV(r->pprivate));
147e3846 2187 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n",
d63e6659 2188 PTR2UV(r->offs));
147e3846 2189 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n",
d63c20f2 2190 PTR2UV(r->qr_anoncv));
db2c6cb3 2191#ifdef PERL_ANY_COW
147e3846 2192 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n",
d63e6659
DM		 2193 PTR2UV(r->saved_copy));
2194#endif
2195 }
206ee256 2196 break;
3967c732 2197 }
5f954473 2198 SvREFCNT_dec_NN(d);
3967c732
JD		 2199}
2200
36b1c95c
MH		 2201/*
2202=for apidoc sv_dump
2203
2204Dumps the contents of an SV to the C<STDERR> filehandle.
2205
2206For an example of its output, see L<Devel::Peek>.
2207
2208=cut
2209*/
2210
3967c732 2211void
864dbfa3 2212Perl_sv_dump(pTHX_ SV *sv)
3967c732 2213{
7918f24d
NC		 2214 PERL_ARGS_ASSERT_SV_DUMP;
2215
d1029faa
JP		 2216 if (SvROK(sv))
2217 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2218 else
2219 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2220}
bd16a5f0
IZ		 2221
2222int
2223Perl_runops_debug(pTHX)
2224{
2225 if (!PL_op) {
9b387841 2226 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ		 2227 return 0;
2228 }
2229
9f3673fb 2230 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2231 do {
75d476e2
S		 2232#ifdef PERL_TRACE_OPS
2233 ++PL_op_exec_cnt[PL_op->op_type];
2234#endif
bd16a5f0 2235 if (PL_debug) {
991bab54
DM		 2236 ENTER;
2237 SAVETMPS;
b9ac451d 2238 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0 2239 PerlIO_printf(Perl_debug_log,
147e3846 2240 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n",
bd16a5f0
IZ		 2241 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2242 PTR2UV(*PL_watchaddr));
d6721266
DM		 2243 if (DEBUG_s_TEST_) {
2244 if (DEBUG_v_TEST_) {
2245 PerlIO_printf(Perl_debug_log, "\n");
2246 deb_stack_all();
2247 }
2248 else
2249 debstack();
2250 }
2251
2252
bd16a5f0
IZ		 2253 if (DEBUG_t_TEST_) debop(PL_op);
2254 if (DEBUG_P_TEST_) debprof(PL_op);
991bab54
DM		 2255 FREETMPS;
2256 LEAVE;
bd16a5f0 2257 }
fe83c362 2258
3f6bd23a 2259 PERL_DTRACE_PROBE_OP(PL_op);
16c91539 2260 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2261 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2262 PERL_ASYNC_CHECK();
bd16a5f0
IZ		 2263
2264 TAINT_NOT;
2265 return 0;
2266}
2267
f9b02e42
DM		 2268
2269/* print the names of the n lexical vars starting at pad offset off */
2270
f9db5646 2271STATIC void
f9b02e42
DM		 2272S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2273{
2274 PADNAME *sv;
2275 CV * const cv = deb_curcv(cxstack_ix);
2276 PADNAMELIST *comppad = NULL;
2277 int i;
2278
2279 if (cv) {
2280 PADLIST * const padlist = CvPADLIST(cv);
2281 comppad = PadlistNAMES(padlist);
2282 }
2283 if (paren)
2284 PerlIO_printf(Perl_debug_log, "(");
2285 for (i = 0; i < n; i++) {
2286 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
147e3846 2287 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv));
f9b02e42 2288 else
147e3846 2289 PerlIO_printf(Perl_debug_log, "[%" UVuf "]",
f9b02e42
DM		 2290 (UV)(off+i));
2291 if (i < n - 1)
2292 PerlIO_printf(Perl_debug_log, ",");
2293 }
2294 if (paren)
2295 PerlIO_printf(Perl_debug_log, ")");
2296}
2297
2298
fedf30e1
DM		 2299/* append to the out SV, the name of the lexical at offset off in the CV
2300 * cv */
2301
ec48399d 2302static void
fedf30e1
DM		 2303S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2304 bool paren, bool is_scalar)
2305{
2306 PADNAME *sv;
2307 PADNAMELIST *namepad = NULL;
2308 int i;
2309
2310 if (cv) {
2311 PADLIST * const padlist = CvPADLIST(cv);
2312 namepad = PadlistNAMES(padlist);
2313 }
2314
2315 if (paren)
2316 sv_catpvs_nomg(out, "(");
2317 for (i = 0; i < n; i++) {
2318 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2319 {
2320 STRLEN cur = SvCUR(out);
147e3846 2321 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f,
26334c4d
FC		 2322 UTF8fARG(1, PadnameLEN(sv) - 1,
2323 PadnamePV(sv) + 1));
fedf30e1
DM		 2324 if (is_scalar)
2325 SvPVX(out)[cur] = '$';
2326 }
2327 else
147e3846 2328 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i));
fedf30e1
DM		 2329 if (i < n - 1)
2330 sv_catpvs_nomg(out, ",");
2331 }
2332 if (paren)
2333 sv_catpvs_nomg(out, "(");
2334}
2335
2336
ec48399d 2337static void
8bbe2fa8 2338S_append_gv_name(pTHX_ GV *gv, SV *out)
fedf30e1
DM		 2339{
2340 SV *sv;
2341 if (!gv) {
2342 sv_catpvs_nomg(out, "<NULLGV>");
2343 return;
2344 }
2345 sv = newSV(0);
2346 gv_fullname4(sv, gv, NULL, FALSE);
147e3846 2347 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv));
fedf30e1
DM		 2348 SvREFCNT_dec_NN(sv);
2349}
2350
2351#ifdef USE_ITHREADS
dc3c1c70
DM		 2352# define ITEM_SV(item) (comppad ? \
2353 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
fedf30e1
DM		 2354#else
2355# define ITEM_SV(item) UNOP_AUX_item_sv(item)
2356#endif
2357
2358
2359/* return a temporary SV containing a stringified representation of
48ee9c0e 2360 * the op_aux field of a MULTIDEREF op, associated with CV cv
fedf30e1
DM		 2361 */
2362
2363SV*
48ee9c0e 2364Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
fedf30e1
DM		 2365{
2366 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2367 UV actions = items->uv;
2368 SV *sv;
2369 bool last = 0;
2370 bool is_hash = FALSE;
2371 int derefs = 0;
ff94d24c 2372 SV *out = newSVpvn_flags("",0,SVs_TEMP);
fedf30e1 2373#ifdef USE_ITHREADS
dc3c1c70
DM		 2374 PAD *comppad;
2375
2376 if (cv) {
2377 PADLIST *padlist = CvPADLIST(cv);
2378 comppad = PadlistARRAY(padlist)[1];
2379 }
2380 else
2381 comppad = NULL;
fedf30e1
DM		 2382#endif
2383
48ee9c0e 2384 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
fedf30e1
DM		 2385
2386 while (!last) {
2387 switch (actions & MDEREF_ACTION_MASK) {
2388
2389 case MDEREF_reload:
2390 actions = (++items)->uv;
2391 continue;
2b5060ae 2392 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2393
2394 case MDEREF_HV_padhv_helem:
2395 is_hash = TRUE;
2b5060ae 2396 /* FALLTHROUGH */
fedf30e1
DM		 2397 case MDEREF_AV_padav_aelem:
2398 derefs = 1;
2399 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2400 goto do_elem;
2b5060ae 2401 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2402
2403 case MDEREF_HV_gvhv_helem:
2404 is_hash = TRUE;
2b5060ae 2405 /* FALLTHROUGH */
fedf30e1
DM		 2406 case MDEREF_AV_gvav_aelem:
2407 derefs = 1;
dc3c1c70
DM		 2408 items++;
2409 sv = ITEM_SV(items);
8bbe2fa8 2410 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2411 goto do_elem;
2b5060ae 2412 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2413
2414 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2415 is_hash = TRUE;
2b5060ae 2416 /* FALLTHROUGH */
fedf30e1 2417 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
dc3c1c70
DM		 2418 items++;
2419 sv = ITEM_SV(items);
8bbe2fa8 2420 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2421 goto do_vivify_rv2xv_elem;
2b5060ae 2422 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2423
2424 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2425 is_hash = TRUE;
2b5060ae 2426 /* FALLTHROUGH */
fedf30e1
DM		 2427 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2428 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2429 goto do_vivify_rv2xv_elem;
2b5060ae 2430 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2431
2432 case MDEREF_HV_pop_rv2hv_helem:
2433 case MDEREF_HV_vivify_rv2hv_helem:
2434 is_hash = TRUE;
2b5060ae 2435 /* FALLTHROUGH */
fedf30e1
DM		 2436 do_vivify_rv2xv_elem:
2437 case MDEREF_AV_pop_rv2av_aelem:
2438 case MDEREF_AV_vivify_rv2av_aelem:
2439 if (!derefs++)
2440 sv_catpvs_nomg(out, "->");
2441 do_elem:
2442 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2443 sv_catpvs_nomg(out, "->");
2444 last = 1;
2445 break;
2446 }
2447
2448 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2449 switch (actions & MDEREF_INDEX_MASK) {
2450 case MDEREF_INDEX_const:
2451 if (is_hash) {
dc3c1c70
DM		 2452 items++;
2453 sv = ITEM_SV(items);
2454 if (!sv)
2455 sv_catpvs_nomg(out, "???");
2456 else {
2457 STRLEN cur;
2458 char *s;
2459 s = SvPV(sv, cur);
2460 pv_pretty(out, s, cur, 30,
2461 NULL, NULL,
2462 (PERL_PV_PRETTY_NOCLEAR
2463 |PERL_PV_PRETTY_QUOTE
2464 |PERL_PV_PRETTY_ELLIPSES));
2465 }
fedf30e1
DM		 2466 }
2467 else
147e3846 2468 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv);
fedf30e1
DM		 2469 break;
2470 case MDEREF_INDEX_padsv:
2471 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2472 break;
2473 case MDEREF_INDEX_gvsv:
dc3c1c70
DM		 2474 items++;
2475 sv = ITEM_SV(items);
8bbe2fa8 2476 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM		 2477 break;
2478 }
2479 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2480
2481 if (actions & MDEREF_FLAG_last)
2482 last = 1;
2483 is_hash = FALSE;
2484
2485 break;
2486
2487 default:
2488 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2489 (int)(actions & MDEREF_ACTION_MASK));
2490 last = 1;
2491 break;
2492
2493 } /* switch */
2494
2495 actions >>= MDEREF_SHIFT;
2496 } /* while */
2497 return out;
2498}
2499
2500
bd16a5f0 2501I32
6867be6d 2502Perl_debop(pTHX_ const OP *o)
bd16a5f0 2503{
7918f24d
NC		 2504 PERL_ARGS_ASSERT_DEBOP;
2505
1045810a
IZ		 2506 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2507 return 0;
2508
bd16a5f0
IZ		 2509 Perl_deb(aTHX_ "%s", OP_NAME(o));
2510 switch (o->op_type) {
2511 case OP_CONST:
996c9baa 2512 case OP_HINTSEVAL:
6cefa69e 2513 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2514 * may not be active here, so check.
6cefa69e 2515 * Looks like only during compiling the pads are illegal.
7367e658 2516 */
6cefa69e
RU		 2517#ifdef USE_ITHREADS
2518 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2519#endif
7367e658 2520 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ		 2521 break;
2522 case OP_GVSV:
2523 case OP_GV:
8333ca1a 2524 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
b9ac451d 2525 SV * const sv = newSV(0);
bd61b366 2526 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2527 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
5f954473 2528 SvREFCNT_dec_NN(sv);
bd16a5f0 2529 }
8333ca1a
FC		 2530 else if (cGVOPo_gv) {
2531 SV * const sv = newSV(0);
2532 assert(SvROK(cGVOPo_gv));
2533 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2534 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
ecf05a58 2535 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
8333ca1a
FC		 2536 SvREFCNT_dec_NN(sv);
2537 }
bd16a5f0
IZ		 2538 else
2539 PerlIO_printf(Perl_debug_log, "(NULL)");
2540 break;
a7fd8ef6 2541
bd16a5f0
IZ		 2542 case OP_PADSV:
2543 case OP_PADAV:
2544 case OP_PADHV:
4fa06845 2545 case OP_ARGELEM:
f9b02e42
DM		 2546 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2547 break;
fedf30e1 2548
a7fd8ef6 2549 case OP_PADRANGE:
f9b02e42
DM		 2550 S_deb_padvar(aTHX_ o->op_targ,
2551 o->op_private & OPpPADRANGE_COUNTMASK, 1);
bd16a5f0 2552 break;
a7fd8ef6 2553
fedf30e1 2554 case OP_MULTIDEREF:
147e3846 2555 PerlIO_printf(Perl_debug_log, "(%" SVf ")",
ac892e4a 2556 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
fedf30e1
DM		 2557 break;
2558
bd16a5f0 2559 default:
091ab601 2560 break;
bd16a5f0
IZ		 2561 }
2562 PerlIO_printf(Perl_debug_log, "\n");
2563 return 0;
2564}
2565
2566STATIC CV*
dc6240c9 2567S_deb_curcv(pTHX_ I32 ix)
bd16a5f0 2568{
dc6240c9
DM		 2569 PERL_SI *si = PL_curstackinfo;
2570 for (; ix >=0; ix--) {
2571 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2572
2573 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2574 return cx->blk_sub.cv;
2575 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2576 return cx->blk_eval.cv;
2577 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2578 return PL_main_cv;
2579 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2580 && si->si_type == PERLSI_SORT)
2581 {
2582 /* fake sort sub; use CV of caller */
2583 si = si->si_prev;
2584 ix = si->si_cxix + 1;
2585 }
2586 }
2587 return NULL;
bd16a5f0
IZ		 2588}
2589
2590void
2591Perl_watch(pTHX_ char **addr)
2592{
7918f24d
NC		 2593 PERL_ARGS_ASSERT_WATCH;
2594
bd16a5f0
IZ		 2595 PL_watchaddr = addr;
2596 PL_watchok = *addr;
147e3846 2597 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n",
bd16a5f0
IZ		 2598 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2599}
2600
2601STATIC void
e1ec3a88 2602S_debprof(pTHX_ const OP *o)
bd16a5f0 2603{
7918f24d
NC		 2604 PERL_ARGS_ASSERT_DEBPROF;
2605
61f9802b 2606 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2607 return;
bd16a5f0 2608 if (!PL_profiledata)
a02a5408 2609 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ		 2610 ++PL_profiledata[o->op_type];
2611}
2612
2613void
2614Perl_debprofdump(pTHX)
2615{
2616 unsigned i;
2617 if (!PL_profiledata)
2618 return;
2619 for (i = 0; i < MAXO; i++) {
2620 if (PL_profiledata[i])
2621 PerlIO_printf(Perl_debug_log,
2622 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2623 PL_op_name[i]);
2624 }
2625}
66610fdd 2626
3b721df9 2627
66610fdd 2628/*
14d04a33 2629 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2630 */
Unnamed repository; edit this file 'description' to name the repository.