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