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