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