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