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