This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dump.c: Dump pmop patterns without trailing )
[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))
f87fee25
FC
645 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n",
646 ch,(int)RX_PRELEN(PM_GETRE(pm)), 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 */
b46e009d 965 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
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,"},
fd01b4b7 1310 {SVf_PROTECT, "PROTECT,"},
a0c2f4dd 1311 {SVf_BREAK, "BREAK,"},
a0c2f4dd
NC
1312 {SVp_IOK, "pIOK,"},
1313 {SVp_NOK, "pNOK,"},
1314 {SVp_POK, "pPOK,"}
1315};
1316
ae1f06a1
NC
1317const struct flag_to_name cv_flags_names[] = {
1318 {CVf_ANON, "ANON,"},
1319 {CVf_UNIQUE, "UNIQUE,"},
1320 {CVf_CLONE, "CLONE,"},
1321 {CVf_CLONED, "CLONED,"},
1322 {CVf_CONST, "CONST,"},
1323 {CVf_NODEBUG, "NODEBUG,"},
1324 {CVf_LVALUE, "LVALUE,"},
1325 {CVf_METHOD, "METHOD,"},
cfc1e951 1326 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1327 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1328 {CVf_DYNFILE, "DYNFILE,"},
8fa6a409 1329 {CVf_AUTOLOAD, "AUTOLOAD,"},
e4555ecf 1330 {CVf_HASEVAL, "HASEVAL,"},
bfbc3ad9 1331 {CVf_SLABBED, "SLABBED,"},
bf9a4d2d 1332 {CVf_NAMED, "NAMED,"},
82487b59 1333 {CVf_LEXICAL, "LEXICAL,"},
31d45e0c 1334 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC
1335};
1336
1337const struct flag_to_name hv_flags_names[] = {
1338 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1339 {SVphv_LAZYDEL, "LAZYDEL,"},
1340 {SVphv_HASKFLAGS, "HASKFLAGS,"},
45eaf8af 1341 {SVf_AMAGIC, "OVERLOAD,"},
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,"},
ae1f06a1
NC
1349};
1350
1351const struct flag_to_name gp_flags_imported_names[] = {
1352 {GVf_IMPORTED_SV, " SV"},
1353 {GVf_IMPORTED_AV, " AV"},
1354 {GVf_IMPORTED_HV, " HV"},
1355 {GVf_IMPORTED_CV, " CV"},
1356};
1357
0d331aaf
YO
1358/* NOTE: this structure is mostly duplicative of one generated by
1359 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1360 * the two. - Yves */
e3e400ec 1361const struct flag_to_name regexp_extflags_names[] = {
d63e6659
DM
1362 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1363 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1364 {RXf_PMf_FOLD, "PMf_FOLD,"},
1365 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
334afb3e 1366 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
d63e6659 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_MBOL, "ANCH_MBOL,"},
1401 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1402 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
e3e400ec
YO
1403};
1404
3967c732 1405void
864dbfa3 1406Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1407{
cea89e20 1408 SV *d;
e1ec3a88 1409 const char *s;
3967c732
JD
1410 U32 flags;
1411 U32 type;
1412
7918f24d
NC
1413 PERL_ARGS_ASSERT_DO_SV_DUMP;
1414
3967c732 1415 if (!sv) {
cea2e8a9 1416 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1417 return;
378cc40b 1418 }
2ef28da1 1419
3967c732
JD
1420 flags = SvFLAGS(sv);
1421 type = SvTYPE(sv);
79072805 1422
e0bbf362
DM
1423 /* process general SV flags */
1424
cea89e20 1425 d = Perl_newSVpvf(aTHX_
57def98f 1426 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
56431972 1427 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS
1428 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1429 (int)(PL_dumpindent*level), "");
8d063cd8 1430
1979170b
NC
1431 if (!((flags & SVpad_NAME) == SVpad_NAME
1432 && (type == SVt_PVMG || type == SVt_PVNV))) {
145bf8ee 1433 if ((flags & SVs_PADSTALE))
9a214eec 1434 sv_catpv(d, "PADSTALE,");
e604303a 1435 }
1979170b 1436 if (!((flags & SVpad_NAME) == SVpad_NAME && type == SVt_PVMG)) {
145bf8ee 1437 if ((flags & SVs_PADTMP))
9a214eec 1438 sv_catpv(d, "PADTMP,");
e604303a 1439 }
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,");
00b1698f 1489 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,");
e604303a 1490 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,");
924ba076 1491 /* FALLTHROUGH */
e604303a
NC
1492 case SVt_PVNV:
1493 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,");
1494 goto evaled_or_uv;
11ca45c0 1495 case SVt_PVAV:
7db6405c 1496 if (AvPAD_NAMELIST(sv)) sv_catpvs(d, "NAMELIST,");
11ca45c0 1497 break;
3967c732 1498 }
86f0d186
NC
1499 /* SVphv_SHAREKEYS is also 0x20000000 */
1500 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1501 sv_catpv(d, "UTF8");
3967c732 1502
b162af07
SP
1503 if (*(SvEND(d) - 1) == ',') {
1504 SvCUR_set(d, SvCUR(d) - 1);
1505 SvPVX(d)[SvCUR(d)] = '\0';
1506 }
3967c732 1507 sv_catpv(d, ")");
b15aece3 1508 s = SvPVX_const(d);
3967c732 1509
e0bbf362
DM
1510 /* dump initial SV details */
1511
fd0854ff 1512#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1513 Perl_dump_indent(aTHX_ level, file,
cd676548 1514 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
fd0854ff
DM
1515 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1516 sv->sv_debug_line,
1517 sv->sv_debug_inpad ? "for" : "by",
1518 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1519 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM
1520 sv->sv_debug_serial
1521 );
fd0854ff 1522#endif
cea2e8a9 1523 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM
1524
1525 /* Dump SV type */
1526
5357ca29
NC
1527 if (type < SVt_LAST) {
1528 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1529
1530 if (type == SVt_NULL) {
5f954473 1531 SvREFCNT_dec_NN(d);
5357ca29
NC
1532 return;
1533 }
1534 } else {
faccc32b 1535 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
5f954473 1536 SvREFCNT_dec_NN(d);
3967c732
JD
1537 return;
1538 }
e0bbf362
DM
1539
1540 /* Dump general SV fields */
1541
27bd069f 1542 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC
1543 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1544 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1545 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1546 if (SvIsUV(sv)
f8c7b90f 1547#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC
1548 || SvIsCOW(sv)
1549#endif
1550 )
57def98f 1551 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1552 else
57def98f 1553 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
f8c7b90f 1554#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC
1555 if (SvIsCOW_shared_hash(sv))
1556 PerlIO_printf(file, " (HASH)");
1557 else if (SvIsCOW_normal(sv))
1558 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1559#endif
3967c732
JD
1560 PerlIO_putc(file, '\n');
1561 }
e0bbf362 1562
1979170b
NC
1563 if ((type == SVt_PVNV || type == SVt_PVMG)
1564 && (SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME) {
0e4c4423
NC
1565 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n",
1566 (UV) COP_SEQ_RANGE_LOW(sv));
1567 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n",
1568 (UV) COP_SEQ_RANGE_HIGH(sv));
1569 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1570 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1571 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1572 || type == SVt_NV) {
e54dc35b 1573 STORE_NUMERIC_LOCAL_SET_STANDARD();
88cb8500 1574 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
e54dc35b 1575 RESTORE_NUMERIC_LOCAL();
3967c732 1576 }
e0bbf362 1577
3967c732 1578 if (SvROK(sv)) {
57def98f 1579 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732
JD
1580 if (nest < maxnest)
1581 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1582 }
e0bbf362 1583
cea89e20 1584 if (type < SVt_PV) {
5f954473 1585 SvREFCNT_dec_NN(d);
3967c732 1586 return;
cea89e20 1587 }
e0bbf362 1588
5a3c7349
FC
1589 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1590 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
8d919b0a
FC
1591 const bool re = isREGEXP(sv);
1592 const char * const ptr =
1593 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1594 if (ptr) {
69240efd 1595 STRLEN delta;
7a4bba22 1596 if (SvOOK(sv)) {
69240efd 1597 SvOOK_offset(sv, delta);
7a4bba22 1598 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
5186cc12 1599 (UV) delta);
69240efd
NC
1600 } else {
1601 delta = 0;
7a4bba22 1602 }
8d919b0a 1603 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
7a4bba22
NC
1604 if (SvOOK(sv)) {
1605 PerlIO_printf(file, "( %s . ) ",
8d919b0a 1606 pv_display(d, ptr - delta, delta, 0,
7a4bba22
NC
1607 pvlim));
1608 }
ad3f05ad
KW
1609 if (type == SVt_INVLIST) {
1610 PerlIO_printf(file, "\n");
1611 /* 4 blanks indents 2 beyond the PV, etc */
1612 _invlist_dump(file, level, " ", sv);
1613 }
1614 else {
685bfc3c
KW
1615 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1616 re ? 0 : SvLEN(sv),
1617 pvlim));
1618 if (SvUTF8(sv)) /* the 6? \x{....} */
1619 PerlIO_printf(file, " [UTF8 \"%s\"]",
1620 sv_uni_display(d, sv, 6 * SvCUR(sv),
1621 UNI_DISPLAY_QQ));
1622 PerlIO_printf(file, "\n");
ad3f05ad 1623 }
57def98f 1624 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
8d919b0a
FC
1625 if (!re)
1626 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1627 (IV)SvLEN(sv));
db2c6cb3
FC
1628#ifdef PERL_NEW_COPY_ON_WRITE
1629 if (SvIsCOW(sv) && SvLEN(sv))
1630 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1631 CowREFCNT(sv));
1632#endif
3967c732
JD
1633 }
1634 else
cea2e8a9 1635 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1636 }
e0bbf362 1637
3967c732 1638 if (type >= SVt_PVMG) {
0e4c4423 1639 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
61f9802b 1640 HV * const ost = SvOURSTASH(sv);
38cbaf55
RGS
1641 if (ost)
1642 do_hv_dump(level, file, " OURSTASH", ost);
7db6405c
FC
1643 } else if (SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)) {
1644 Perl_dump_indent(aTHX_ level, file, " MAXNAMED = %"UVuf"\n",
1645 (UV)PadnamelistMAXNAMED(sv));
0e4c4423
NC
1646 } else {
1647 if (SvMAGIC(sv))
8530ff28 1648 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
0e4c4423 1649 }
3967c732
JD
1650 if (SvSTASH(sv))
1651 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC
1652
1653 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
c13a5c80
NC
1654 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1655 }
3967c732 1656 }
e0bbf362
DM
1657
1658 /* Dump type-specific SV fields */
1659
3967c732 1660 switch (type) {
3967c732 1661 case SVt_PVAV:
57def98f 1662 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1663 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f
JH
1664 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1665 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732
JD
1666 }
1667 else
1668 PerlIO_putc(file, '\n');
57def98f
JH
1669 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1670 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
7db6405c
FC
1671 /* arylen is stored in magic, and padnamelists use SvMAGIC for
1672 something else. */
1673 if (!AvPAD_NAMELIST(sv))
1674 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
1675 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
76f68e9b 1676 sv_setpvs(d, "");
11ca45c0
NC
1677 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1678 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP
1679 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1680 SvCUR(d) ? SvPVX_const(d) + 1 : "");
b9f2b683 1681 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
c70927a6 1682 SSize_t count;
b9f2b683 1683 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
502c6561 1684 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
3967c732 1685
57def98f 1686 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
2ef28da1 1687 if (elt)
3967c732
JD
1688 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1689 }
1690 }
1691 break;
5d27ee4a
DD
1692 case SVt_PVHV: {
1693 U32 usedkeys;
0c22a733
DM
1694 if (SvOOK(sv)) {
1695 struct xpvhv_aux *const aux = HvAUX(sv);
1696 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1697 (UV)aux->xhv_aux_flags);
1698 }
57def98f 1699 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
5d27ee4a
DD
1700 usedkeys = HvUSEDKEYS(sv);
1701 if (HvARRAY(sv) && usedkeys) {
3967c732
JD
1702 /* Show distribution of HEs in the ARRAY */
1703 int freq[200];
c3caa5c3 1704#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
3967c732
JD
1705 int i;
1706 int max = 0;
5d27ee4a 1707 U32 pow2 = 2, keys = usedkeys;
65202027 1708 NV theoret, sum = 0;
3967c732
JD
1709
1710 PerlIO_printf(file, " (");
1711 Zero(freq, FREQ_MAX + 1, int);
eb160463 1712 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL
1713 HE* h;
1714 int count = 0;
3967c732
JD
1715 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1716 count++;
1717 if (count > FREQ_MAX)
1718 count = FREQ_MAX;
1719 freq[count]++;
1720 if (max < count)
1721 max = count;
1722 }
1723 for (i = 0; i <= max; i++) {
1724 if (freq[i]) {
1725 PerlIO_printf(file, "%d%s:%d", i,
1726 (i == FREQ_MAX) ? "+" : "",
1727 freq[i]);
1728 if (i != max)
1729 PerlIO_printf(file, ", ");
1730 }
1731 }
1732 PerlIO_putc(file, ')');
b8fa94d8
MG
1733 /* The "quality" of a hash is defined as the total number of
1734 comparisons needed to access every element once, relative
1735 to the expected number needed for a random hash.
1736
1737 The total number of comparisons is equal to the sum of
e76cd0fa
AMS
1738 the squares of the number of entries in each bucket.
1739 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG
1740 value is
1741 n + n(n-1)/2k
1742 */
1743
3967c732
JD
1744 for (i = max; i > 0; i--) { /* Precision: count down. */
1745 sum += freq[i] * i * i;
1746 }
155aba94 1747 while ((keys = keys >> 1))
3967c732 1748 pow2 = pow2 << 1;
5d27ee4a 1749 theoret = usedkeys;
b8fa94d8 1750 theoret += theoret * (theoret-1)/pow2;
3967c732 1751 PerlIO_putc(file, '\n');
6b4667fc 1752 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732
JD
1753 }
1754 PerlIO_putc(file, '\n');
5d27ee4a 1755 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
9faf471a
NC
1756 {
1757 STRLEN count = 0;
1758 HE **ents = HvARRAY(sv);
1759
1760 if (ents) {
1761 HE *const *const last = ents + HvMAX(sv);
1762 count = last + 1 - ents;
1763
1764 do {
1765 if (!*ents)
1766 --count;
1767 } while (++ents <= last);
1768 }
1769
1770 if (SvOOK(sv)) {
1771 struct xpvhv_aux *const aux = HvAUX(sv);
1772 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1773 " (cached = %"UVuf")\n",
1774 (UV)count, (UV)aux->xhv_fill_lazy);
1775 } else {
1776 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1777 (UV)count);
1778 }
1779 }
57def98f 1780 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
e1a7ec8d
YO
1781 if (SvOOK(sv)) {
1782 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1783 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
6a5b4183 1784#ifdef PERL_HASH_RANDOMIZE_KEYS
e1a7ec8d
YO
1785 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1786 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
6a5b4183 1787 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
e1a7ec8d 1788 }
6a5b4183
YO
1789#endif
1790 PerlIO_putc(file, '\n');
e1a7ec8d 1791 }
8d2f4536 1792 {
b9ac451d 1793 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536
NC
1794 if (mg && mg->mg_obj) {
1795 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1796 }
1797 }
bfcb3514 1798 {
b9ac451d 1799 const char * const hvname = HvNAME_get(sv);
0eb335df
BF
1800 if (hvname) {
1801 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1802 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1803 generic_pv_escape( tmpsv, hvname,
1804 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1805 }
bfcb3514 1806 }
86f55936 1807 if (SvOOK(sv)) {
ad64d0ec 1808 AV * const backrefs
85fbaab2 1809 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 1810 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC
1811 if (HvAUX(sv)->xhv_name_count)
1812 Perl_dump_indent(aTHX_
7afc2217
FC
1813 level, file, " NAMECOUNT = %"IVdf"\n",
1814 (IV)HvAUX(sv)->xhv_name_count
67e04715 1815 );
15d9236d 1816 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC
1817 const I32 count = HvAUX(sv)->xhv_name_count;
1818 if (count) {
1819 SV * const names = newSVpvs_flags("", SVs_TEMP);
1820 /* The starting point is the first element if count is
1821 positive and the second element if count is negative. */
1822 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1823 + (count < 0 ? 1 : 0);
1824 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1825 + (count < 0 ? -count : count);
1826 while (hekp < endp) {
0eb335df
BF
1827 if (HEK_LEN(*hekp)) {
1828 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1829 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1830 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
ec3405c8
NC
1831 } else {
1832 /* This should never happen. */
1833 sv_catpvs(names, ", (null)");
67e04715 1834 }
ec3405c8
NC
1835 ++hekp;
1836 }
67e04715
FC
1837 Perl_dump_indent(aTHX_
1838 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1839 );
1840 }
0eb335df
BF
1841 else {
1842 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1843 const char *const hvename = HvENAME_get(sv);
67e04715 1844 Perl_dump_indent(aTHX_
0eb335df
BF
1845 level, file, " ENAME = \"%s\"\n",
1846 generic_pv_escape(tmp, hvename,
1847 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1848 }
67e04715 1849 }
86f55936
NC
1850 if (backrefs) {
1851 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1852 PTR2UV(backrefs));
ad64d0ec 1853 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC
1854 dumpops, pvlim);
1855 }
7d88e6c4 1856 if (meta) {
0eb335df
BF
1857 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1858 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1859 generic_pv_escape( tmpsv, meta->mro_which->name,
1860 meta->mro_which->length,
1861 (meta->mro_which->kflags & HVhek_UTF8)),
7d88e6c4
NC
1862 PTR2UV(meta->mro_which));
1863 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1864 (UV)meta->cache_gen);
1865 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1866 (UV)meta->pkg_gen);
1867 if (meta->mro_linear_all) {
1868 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1869 PTR2UV(meta->mro_linear_all));
1870 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1871 dumpops, pvlim);
1872 }
1873 if (meta->mro_linear_current) {
1874 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1875 PTR2UV(meta->mro_linear_current));
1876 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1877 dumpops, pvlim);
1878 }
1879 if (meta->mro_nextmethod) {
1880 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1881 PTR2UV(meta->mro_nextmethod));
1882 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1883 dumpops, pvlim);
1884 }
1885 if (meta->isa) {
1886 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1887 PTR2UV(meta->isa));
1888 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1889 dumpops, pvlim);
1890 }
1891 }
86f55936 1892 }
b5698553 1893 if (nest < maxnest) {
cbab3169 1894 HV * const hv = MUTABLE_HV(sv);
b5698553
TH
1895 STRLEN i;
1896 HE *he;
cbab3169 1897
b5698553
TH
1898 if (HvARRAY(hv)) {
1899 int count = maxnest - nest;
1900 for (i=0; i <= HvMAX(hv); i++) {
1901 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1902 U32 hash;
1903 SV * keysv;
1904 const char * keypv;
1905 SV * elt;
7dc86639 1906 STRLEN len;
b5698553
TH
1907
1908 if (count-- <= 0) goto DONEHV;
1909
1910 hash = HeHASH(he);
1911 keysv = hv_iterkeysv(he);
1912 keypv = SvPV_const(keysv, len);
1913 elt = HeVAL(he);
cbab3169 1914
7dc86639
YO
1915 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1916 if (SvUTF8(keysv))
1917 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH
1918 if (HvEITER_get(hv) == he)
1919 PerlIO_printf(file, "[CURRENT] ");
7dc86639
YO
1920 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1921 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1922 }
b5698553
TH
1923 }
1924 DONEHV:;
1925 }
3967c732
JD
1926 }
1927 break;
5d27ee4a 1928 } /* case SVt_PVHV */
e0bbf362 1929
3967c732 1930 case SVt_PVCV:
8fa6a409 1931 if (CvAUTOLOAD(sv)) {
0eb335df
BF
1932 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1933 STRLEN len;
8fa6a409 1934 const char *const name = SvPV_const(sv, len);
0eb335df
BF
1935 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1936 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
8fa6a409
FC
1937 }
1938 if (SvPOK(sv)) {
0eb335df
BF
1939 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1940 const char *const proto = CvPROTO(sv);
1941 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1942 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1943 SvUTF8(sv)));
cbf82dd0 1944 }
924ba076 1945 /* FALLTHROUGH */
3967c732
JD
1946 case SVt_PVFM:
1947 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC
1948 if (!CvISXSUB(sv)) {
1949 if (CvSTART(sv)) {
1950 Perl_dump_indent(aTHX_ level, file,
1951 " START = 0x%"UVxf" ===> %"IVdf"\n",
1952 PTR2UV(CvSTART(sv)),
1953 (IV)sequence_num(CvSTART(sv)));
1954 }
1955 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1956 PTR2UV(CvROOT(sv)));
1957 if (CvROOT(sv) && dumpops) {
1958 do_op_dump(level+1, file, CvROOT(sv));
1959 }
1960 } else {
126f53f3 1961 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 1962
d04ba589 1963 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099
NC
1964
1965 if (constant) {
1966 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1967 " (CONST SV)\n",
1968 PTR2UV(CvXSUBANY(sv).any_ptr));
1969 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1970 pvlim);
1971 } else {
1972 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1973 (IV)CvXSUBANY(sv).any_i32);
1974 }
1975 }
3610c89f
FC
1976 if (CvNAMED(sv))
1977 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1978 HEK_KEY(CvNAME_HEK((CV *)sv)));
1979 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1980 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
bb02a38f 1981 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 1982 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 1983 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
57def98f 1984 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
dd2155a4
DM
1985 if (nest < maxnest) {
1986 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
3967c732
JD
1987 }
1988 {
b9ac451d 1989 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 1990 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 1991 PTR2UV(outside),
cf2093f6
JH
1992 (!outside ? "null"
1993 : CvANON(outside) ? "ANON"
1994 : (outside == PL_main_cv) ? "MAIN"
1995 : CvUNIQUE(outside) ? "UNIQUE"
b24fda9d
BF
1996 : CvGV(outside) ?
1997 generic_pv_escape(
1998 newSVpvs_flags("", SVs_TEMP),
1999 GvNAME(CvGV(outside)),
2000 GvNAMELEN(CvGV(outside)),
2001 GvNAMEUTF8(CvGV(outside)))
2002 : "UNDEFINED"));
3967c732
JD
2003 }
2004 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
ad64d0ec 2005 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2006 break;
e0bbf362 2007
926fc7b6
DM
2008 case SVt_PVGV:
2009 case SVt_PVLV:
b9ac451d
AL
2010 if (type == SVt_PVLV) {
2011 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2012 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2013 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2014 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
83f78d1a 2015 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
305b8651 2016 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
b9ac451d
AL
2017 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2018 dumpops, pvlim);
2019 }
8d919b0a 2020 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM
2021 if (!isGV_with_GP(sv))
2022 break;
0eb335df
BF
2023 {
2024 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2025 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2026 generic_pv_escape(tmpsv, GvNAME(sv),
2027 GvNAMELEN(sv),
2028 GvNAMEUTF8(sv)));
2029 }
57def98f 2030 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 2031 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
be108a01 2032 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
57def98f 2033 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c
GS
2034 if (!GvGP(sv))
2035 break;
57def98f
JH
2036 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2037 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2038 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2040 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2041 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2042 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2043 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
008009b0
FC
2044 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
2045 " (%s)\n",
2046 (UV)GvGPFLAGS(sv),
2047 GvALIASED_SV(sv) ? "ALIASED_SV" : "");
57def98f 2048 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 2049 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
3967c732
JD
2050 do_gv_dump (level, file, " EGV", GvEGV(sv));
2051 break;
2052 case SVt_PVIO:
57def98f
JH
2053 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2054 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2055 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2056 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2057 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2058 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2059 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 2060 if (IoTOP_NAME(sv))
cea2e8a9 2061 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC
2062 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2063 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2064 else {
2065 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2066 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC
2067 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2068 maxnest, dumpops, pvlim);
9ba1f565
NC
2069 }
2070 /* Source filters hide things that are not GVs in these three, so let's
2071 be careful out there. */
27533608 2072 if (IoFMT_NAME(sv))
cea2e8a9 2073 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC
2074 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2075 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2076 else {
2077 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2078 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC
2079 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2080 maxnest, dumpops, pvlim);
9ba1f565 2081 }
27533608 2082 if (IoBOTTOM_NAME(sv))
cea2e8a9 2083 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC
2084 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2085 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2086 else {
2087 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2088 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC
2089 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2090 maxnest, dumpops, pvlim);
9ba1f565 2091 }
27533608 2092 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2093 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2094 else
cea2e8a9 2095 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 2096 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732 2097 break;
206ee256 2098 case SVt_REGEXP:
8d919b0a 2099 dumpregexp:
d63e6659 2100 {
8d919b0a 2101 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO
2102
2103#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2104 sv_setpv(d,""); \
e3e400ec 2105 append_flags(d, flags, names); \
ec16d31f
YO
2106 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2107 SvCUR_set(d, SvCUR(d) - 1); \
2108 SvPVX(d)[SvCUR(d)] = '\0'; \
2109 } \
2110} STMT_END
e3e400ec 2111 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
dbc200c5
YO
2112 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2113 (UV)(r->compflags), SvPVX_const(d));
2114
e3e400ec 2115 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
d63e6659 2116 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
dbc200c5
YO
2117 (UV)(r->extflags), SvPVX_const(d));
2118
e3e400ec
YO
2119 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2120 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2121 if (r->engine == &PL_core_reg_engine) {
2122 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2123 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2124 (UV)(r->intflags), SvPVX_const(d));
2125 } else {
2126 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
d63e6659 2127 (UV)(r->intflags));
e3e400ec
YO
2128 }
2129#undef SV_SET_STRINGIFY_REGEXP_FLAGS
d63e6659
DM
2130 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2131 (UV)(r->nparens));
2132 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2133 (UV)(r->lastparen));
2134 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2135 (UV)(r->lastcloseparen));
2136 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2137 (IV)(r->minlen));
2138 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2139 (IV)(r->minlenret));
2140 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2141 (UV)(r->gofs));
2142 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2143 (UV)(r->pre_prefix));
d63e6659
DM
2144 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2145 (IV)(r->sublen));
6502e081
DM
2146 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2147 (IV)(r->suboffset));
2148 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2149 (IV)(r->subcoffset));
d63e6659
DM
2150 if (r->subbeg)
2151 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2152 PTR2UV(r->subbeg),
2153 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2154 else
2155 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
d63e6659
DM
2156 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2157 PTR2UV(r->mother_re));
01ffd0f1
FC
2158 if (nest < maxnest && r->mother_re)
2159 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2160 maxnest, dumpops, pvlim);
d63e6659
DM
2161 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2162 PTR2UV(r->paren_names));
2163 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2164 PTR2UV(r->substrs));
2165 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2166 PTR2UV(r->pprivate));
2167 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2168 PTR2UV(r->offs));
d63c20f2
DM
2169 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2170 PTR2UV(r->qr_anoncv));
db2c6cb3 2171#ifdef PERL_ANY_COW
d63e6659
DM
2172 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2173 PTR2UV(r->saved_copy));
2174#endif
2175 }
206ee256 2176 break;
3967c732 2177 }
5f954473 2178 SvREFCNT_dec_NN(d);
3967c732
JD
2179}
2180
36b1c95c
MH
2181/*
2182=for apidoc sv_dump
2183
2184Dumps the contents of an SV to the C<STDERR> filehandle.
2185
2186For an example of its output, see L<Devel::Peek>.
2187
2188=cut
2189*/
2190
3967c732 2191void
864dbfa3 2192Perl_sv_dump(pTHX_ SV *sv)
3967c732 2193{
7918f24d
NC
2194 PERL_ARGS_ASSERT_SV_DUMP;
2195
d1029faa
JP
2196 if (SvROK(sv))
2197 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2198 else
2199 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2200}
bd16a5f0
IZ
2201
2202int
2203Perl_runops_debug(pTHX)
2204{
2205 if (!PL_op) {
9b387841 2206 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ
2207 return 0;
2208 }
2209
9f3673fb 2210 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2211 do {
75d476e2
SM
2212#ifdef PERL_TRACE_OPS
2213 ++PL_op_exec_cnt[PL_op->op_type];
2214#endif
bd16a5f0 2215 if (PL_debug) {
b9ac451d 2216 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0
IZ
2217 PerlIO_printf(Perl_debug_log,
2218 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2219 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2220 PTR2UV(*PL_watchaddr));
d6721266
DM
2221 if (DEBUG_s_TEST_) {
2222 if (DEBUG_v_TEST_) {
2223 PerlIO_printf(Perl_debug_log, "\n");
2224 deb_stack_all();
2225 }
2226 else
2227 debstack();
2228 }
2229
2230
bd16a5f0
IZ
2231 if (DEBUG_t_TEST_) debop(PL_op);
2232 if (DEBUG_P_TEST_) debprof(PL_op);
2233 }
fe83c362
SM
2234
2235 OP_ENTRY_PROBE(OP_NAME(PL_op));
16c91539 2236 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2237 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2238 PERL_ASYNC_CHECK();
bd16a5f0
IZ
2239
2240 TAINT_NOT;
2241 return 0;
2242}
2243
2244I32
6867be6d 2245Perl_debop(pTHX_ const OP *o)
bd16a5f0 2246{
81d52ecd 2247 int count;
7918f24d
NC
2248
2249 PERL_ARGS_ASSERT_DEBOP;
2250
1045810a
IZ
2251 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2252 return 0;
2253
bd16a5f0
IZ
2254 Perl_deb(aTHX_ "%s", OP_NAME(o));
2255 switch (o->op_type) {
2256 case OP_CONST:
996c9baa 2257 case OP_HINTSEVAL:
6cefa69e 2258 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2259 * may not be active here, so check.
6cefa69e 2260 * Looks like only during compiling the pads are illegal.
7367e658 2261 */
6cefa69e
RU
2262#ifdef USE_ITHREADS
2263 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2264#endif
7367e658 2265 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ
2266 break;
2267 case OP_GVSV:
2268 case OP_GV:
8333ca1a 2269 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
b9ac451d 2270 SV * const sv = newSV(0);
bd61b366 2271 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2272 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
5f954473 2273 SvREFCNT_dec_NN(sv);
bd16a5f0 2274 }
8333ca1a
FC
2275 else if (cGVOPo_gv) {
2276 SV * const sv = newSV(0);
2277 assert(SvROK(cGVOPo_gv));
2278 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2279 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
ecf05a58 2280 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
8333ca1a
FC
2281 SvREFCNT_dec_NN(sv);
2282 }
bd16a5f0
IZ
2283 else
2284 PerlIO_printf(Perl_debug_log, "(NULL)");
2285 break;
a7fd8ef6 2286
bd16a5f0
IZ
2287 case OP_PADSV:
2288 case OP_PADAV:
2289 case OP_PADHV:
a7fd8ef6
DM
2290 count = 1;
2291 goto dump_padop;
2292 case OP_PADRANGE:
2293 count = o->op_private & OPpPADRANGE_COUNTMASK;
2294 dump_padop:
bd16a5f0 2295 /* print the lexical's name */
a7fd8ef6
DM
2296 {
2297 CV * const cv = deb_curcv(cxstack_ix);
2298 SV *sv;
2299 PAD * comppad = NULL;
2300 int i;
2301
2302 if (cv) {
2303 PADLIST * const padlist = CvPADLIST(cv);
2304 comppad = *PadlistARRAY(padlist);
2305 }
2306 PerlIO_printf(Perl_debug_log, "(");
2307 for (i = 0; i < count; i++) {
2308 if (comppad &&
2309 (sv = *av_fetch(comppad, o->op_targ + i, FALSE)))
2310 PerlIO_printf(Perl_debug_log, "%s", SvPV_nolen_const(sv));
2311 else
2312 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2313 (UV)o->op_targ+i);
2314 if (i < count-1)
2315 PerlIO_printf(Perl_debug_log, ",");
2316 }
2317 PerlIO_printf(Perl_debug_log, ")");
2318 }
bd16a5f0 2319 break;
a7fd8ef6 2320
bd16a5f0 2321 default:
091ab601 2322 break;
bd16a5f0
IZ
2323 }
2324 PerlIO_printf(Perl_debug_log, "\n");
2325 return 0;
2326}
2327
2328STATIC CV*
61f9802b 2329S_deb_curcv(pTHX_ const I32 ix)
bd16a5f0 2330{
b9ac451d 2331 const PERL_CONTEXT * const cx = &cxstack[ix];
bd16a5f0
IZ
2332 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2333 return cx->blk_sub.cv;
2334 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
676a678a 2335 return cx->blk_eval.cv;
bd16a5f0
IZ
2336 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2337 return PL_main_cv;
2338 else if (ix <= 0)
601f1833 2339 return NULL;
bd16a5f0
IZ
2340 else
2341 return deb_curcv(ix - 1);
2342}
2343
2344void
2345Perl_watch(pTHX_ char **addr)
2346{
7918f24d
NC
2347 PERL_ARGS_ASSERT_WATCH;
2348
bd16a5f0
IZ
2349 PL_watchaddr = addr;
2350 PL_watchok = *addr;
2351 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2352 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2353}
2354
2355STATIC void
e1ec3a88 2356S_debprof(pTHX_ const OP *o)
bd16a5f0 2357{
7918f24d
NC
2358 PERL_ARGS_ASSERT_DEBPROF;
2359
61f9802b 2360 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2361 return;
bd16a5f0 2362 if (!PL_profiledata)
a02a5408 2363 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ
2364 ++PL_profiledata[o->op_type];
2365}
2366
2367void
2368Perl_debprofdump(pTHX)
2369{
2370 unsigned i;
2371 if (!PL_profiledata)
2372 return;
2373 for (i = 0; i < MAXO; i++) {
2374 if (PL_profiledata[i])
2375 PerlIO_printf(Perl_debug_log,
2376 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2377 PL_op_name[i]);
2378 }
2379}
66610fdd 2380
3b721df9 2381
66610fdd
RGS
2382/*
2383 * Local variables:
2384 * c-indentation-style: bsd
2385 * c-basic-offset: 4
14d04a33 2386 * indent-tabs-mode: nil
66610fdd
RGS
2387 * End:
2388 *
14d04a33 2389 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2390 */