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
Remove no longer valid tests
[perl5.git] / dump.c
CommitLineData
a0d0e21e 1/* dump.c
a687059c 2 *
1129b882
NC		 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
a687059c 5 *
6e21c824
LW		 6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8d063cd8 8 *
a0d0e21e
LW		 9 */
10
11/*
4ac71550
TC		 12 * 'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
13 * it has not been hard for me to read your mind and memory.'
14 *
15 * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"]
8d063cd8
LW		 16 */
17
166f8a29 18/* This file contains utility routines to dump the contents of SV and OP
61296642 19 * structures, as used by command-line options like -Dt and -Dx, and
166f8a29
DM		 20 * by Devel::Peek.
21 *
22 * It also holds the debugging version of the runops function.
dcccc8ff
KW		 23
24=head1 Display and Dump functions
166f8a29
DM		 25 */
26
8d063cd8 27#include "EXTERN.h"
864dbfa3 28#define PERL_IN_DUMP_C
8d063cd8 29#include "perl.h"
f722798b 30#include "regcomp.h"
0bd48802 31
5357ca29
NC		 32static const char* const svtypenames[SVt_LAST] = {
33 "NULL",
34 "IV",
b53eecb4 35 "NV",
5357ca29 36 "PV",
e94d9b54 37 "INVLIST",
5357ca29
NC		 38 "PVIV",
39 "PVNV",
40 "PVMG",
5c35adbb 41 "REGEXP",
5357ca29
NC		 42 "PVGV",
43 "PVLV",
44 "PVAV",
45 "PVHV",
46 "PVCV",
47 "PVFM",
48 "PVIO"
49};
50
51
52static const char* const svshorttypenames[SVt_LAST] = {
53 "UNDEF",
54 "IV",
b53eecb4 55 "NV",
5357ca29 56 "PV",
e94d9b54 57 "INVLST",
5357ca29
NC		 58 "PVIV",
59 "PVNV",
60 "PVMG",
5c35adbb 61 "REGEXP",
5357ca29
NC		 62 "GV",
63 "PVLV",
64 "AV",
65 "HV",
66 "CV",
67 "FM",
68 "IO"
69};
70
a0c2f4dd
NC		 71struct flag_to_name {
72 U32 flag;
73 const char *name;
74};
75
76static void
77S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start,
78 const struct flag_to_name *const end)
79{
80 do {
81 if (flags & start->flag)
82 sv_catpv(sv, start->name);
83 } while (++start < end);
84}
85
86#define append_flags(sv, f, flags) \
cd431fde 87 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags))
a0c2f4dd 88
0eb335df
BF		 89#define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \
90 (len) * (4+UTF8_MAXBYTES) + 1, NULL, \
91 PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \
92 | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) )
93
3df15adc 94/*
87cea99e 95=for apidoc pv_escape
3df15adc 96
796b6530
KW		 97Escapes at most the first C<count> chars of C<pv> and puts the results into
98C<dsv> such that the size of the escaped string will not exceed C<max> chars
9a63e366 99and will not contain any incomplete escape sequences. The number of bytes
796b6530
KW		 100escaped will be returned in the C<STRLEN *escaped> parameter if it is not null.
101When the C<dsv> parameter is null no escaping actually occurs, but the number
4420a417 102of bytes that would be escaped were it not null will be calculated.
3df15adc 103
796b6530 104If flags contains C<PERL_PV_ESCAPE_QUOTE> then any double quotes in the string
ab3bbdeb 105will also be escaped.
3df15adc
YO		 106
107Normally the SV will be cleared before the escaped string is prepared,
796b6530 108but when C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur.
ab3bbdeb 109
796b6530
KW		 110If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8
111if C<PERL_PV_ESCAPE_UNI_DETECT> is set then the input string is scanned
e5860534 112using C<is_utf8_string()> to determine if it is UTF-8.
ab3bbdeb 113
796b6530
KW		 114If C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output
115using C<\x01F1> style escapes, otherwise if C<PERL_PV_ESCAPE_NONASCII> is set, only
951cbe24 116non-ASCII chars will be escaped using this style; otherwise, only chars above
681f01c2 117255 will be so escaped; other non printable chars will use octal or
72d33970 118common escaped patterns like C<\n>.
796b6530 119Otherwise, if C<PERL_PV_ESCAPE_NOBACKSLASH>
681f01c2 120then all chars below 255 will be treated as printable and
ab3bbdeb
YO		 121will be output as literals.
122
796b6530 123If C<PERL_PV_ESCAPE_FIRSTCHAR> is set then only the first char of the
72d33970 124string will be escaped, regardless of max. If the output is to be in hex,
c8536afa 125then it will be returned as a plain hex
72d33970 126sequence. Thus the output will either be a single char,
c8536afa 127an octal escape sequence, a special escape like C<\n> or a hex value.
3df15adc 128
796b6530
KW		 129If C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a C<"%"> and
130not a C<"\\">. This is because regexes very often contain backslashed
131sequences, whereas C<"%"> is not a particularly common character in patterns.
44a2ac75 132
796b6530 133Returns a pointer to the escaped text as held by C<dsv>.
3df15adc
YO		 134
135=cut
136*/
ab3bbdeb 137#define PV_ESCAPE_OCTBUFSIZE 32
ddc5bc0f 138
3967c732 139char *
ddc5bc0f 140Perl_pv_escape( pTHX_ SV *dsv, char const * const str,
ab3bbdeb
YO		 141 const STRLEN count, const STRLEN max,
142 STRLEN * const escaped, const U32 flags )
143{
61f9802b
AL		 144 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\';
145 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc;
44a2ac75 146 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF";
ab3bbdeb
YO		 147 STRLEN wrote = 0; /* chars written so far */
148 STRLEN chsize = 0; /* size of data to be written */
149 STRLEN readsize = 1; /* size of data just read */
e5860534 150 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this UTF-8 */
ddc5bc0f 151 const char *pv = str;
61f9802b 152 const char * const end = pv + count; /* end of string */
44a2ac75 153 octbuf[0] = esc;
ab3bbdeb 154
7918f24d
NC		 155 PERL_ARGS_ASSERT_PV_ESCAPE;
156
4420a417 157 if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) {
7fddd944 158 /* This won't alter the UTF-8 flag */
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
796b6530 252C<pv_escape()> and supporting quoting and ellipses.
ab3bbdeb 253
796b6530 254If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be
72d33970 255double quoted with any double quotes in the string escaped. Otherwise
796b6530 256if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in
ab3bbdeb 257angle brackets.
6cba11c8 258
796b6530 259If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in
95b611b0 260string were output then an ellipsis C<...> will be appended to the
72d33970 261string. Note that this happens AFTER it has been quoted.
6cba11c8 262
796b6530
KW		 263If C<start_color> is non-null then it will be inserted after the opening
264quote (if there is one) but before the escaped text. If C<end_color>
ab3bbdeb 265is non-null then it will be inserted after the escaped text but before
95b611b0 266any quotes or ellipses.
ab3bbdeb 267
796b6530 268Returns a pointer to the prettified text as held by C<dsv>.
6cba11c8 269
ab3bbdeb
YO		 270=cut
271*/
272
273char *
ddc5bc0f
YO		 274Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count,
275 const STRLEN max, char const * const start_color, char const * const end_color,
ab3bbdeb
YO		 276 const U32 flags )
277{
3602166e
FC		 278 const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" :
279 (flags & PERL_PV_PRETTY_LTGT) ? "<>" : NULL);
ab3bbdeb 280 STRLEN escaped;
4420a417
YO		 281 STRLEN max_adjust= 0;
282 STRLEN orig_cur;
7918f24d
NC		 283
284 PERL_ARGS_ASSERT_PV_PRETTY;
285
881a015e 286 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) {
4420a417
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);
1e9f2263 971 break;
fedf30e1
DM		 972 }
973
79072805 974 case OP_CONST:
996c9baa 975 case OP_HINTSEVAL:
f5d5a27c 976 case OP_METHOD_NAMED:
7d6c333c 977 case OP_METHOD_SUPER:
810bd8b7 978 case OP_METHOD_REDIR:
979 case OP_METHOD_REDIR_SUPER:
b6a15bc5
DM		 980#ifndef USE_ITHREADS
981 /* with ITHREADS, consts are stored in the pad, and the right pad
982 * may not be active here, so skip */
b46e009d 983 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
b6a15bc5 984#endif
79072805 985 break;
5e412b02
FC		 986 case OP_NULL:
987 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
988 break;
989 /* FALLTHROUGH */
93a17b20
LW		 990 case OP_NEXTSTATE:
991 case OP_DBSTATE:
57843af0 992 if (CopLINE(cCOPo))
f5992bc4 993 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
9d98dee5 994 (UV)CopLINE(cCOPo));
0eb335df
BF		 995 if (CopSTASHPV(cCOPo)) {
996 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
997 HV *stash = CopSTASH(cCOPo);
998 const char * const hvname = HvNAME_get(stash);
999
ed094faf 1000 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
0eb335df
BF		 1001 generic_pv_escape(tmpsv, hvname,
1002 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1003 }
1004 if (CopLABEL(cCOPo)) {
1005 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1006 STRLEN label_len;
1007 U32 label_flags;
1008 const char *label = CopLABEL_len_flags(cCOPo,
1009 &label_len, &label_flags);
1010 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1011 generic_pv_escape( tmpsv, label, label_len,
1012 (label_flags & SVf_UTF8)));
1013 }
7fa99c80 1014 Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
947a9e0f 1015 (unsigned int)cCOPo->cop_seq);
79072805
LW		 1016 break;
1017 case OP_ENTERLOOP:
cea2e8a9 1018 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
11343788 1019 if (cLOOPo->op_redoop)
f5992bc4 1020 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
79072805 1021 else
3967c732 1022 PerlIO_printf(file, "DONE\n");
cea2e8a9 1023 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
11343788 1024 if (cLOOPo->op_nextop)
f5992bc4 1025 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
79072805 1026 else
3967c732 1027 PerlIO_printf(file, "DONE\n");
cea2e8a9 1028 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
11343788 1029 if (cLOOPo->op_lastop)
f5992bc4 1030 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
79072805 1031 else
3967c732 1032 PerlIO_printf(file, "DONE\n");
79072805
LW		 1033 break;
1034 case OP_COND_EXPR:
1a67a97c 1035 case OP_RANGE:
a0d0e21e 1036 case OP_MAPWHILE:
79072805
LW		 1037 case OP_GREPWHILE:
1038 case OP_OR:
1039 case OP_AND:
cea2e8a9 1040 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
11343788 1041 if (cLOGOPo->op_other)
f5992bc4 1042 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
79072805 1043 else
3967c732 1044 PerlIO_printf(file, "DONE\n");
79072805
LW		 1045 break;
1046 case OP_PUSHRE:
1047 case OP_MATCH:
8782bef2 1048 case OP_QR:
79072805 1049 case OP_SUBST:
3967c732 1050 do_pmop_dump(level, file, cPMOPo);
79072805 1051 break;
7934575e
GS		 1052 case OP_LEAVE:
1053 case OP_LEAVEEVAL:
1054 case OP_LEAVESUB:
1055 case OP_LEAVESUBLV:
1056 case OP_LEAVEWRITE:
1057 case OP_SCOPE:
1058 if (o->op_private & OPpREFCOUNTED)
1059 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1060 break;
a0d0e21e
LW		 1061 default:
1062 break;
79072805 1063 }
11343788 1064 if (o->op_flags & OPf_KIDS) {
79072805 1065 OP *kid;
e6dae479 1066 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3967c732 1067 do_op_dump(level, file, kid);
8d063cd8 1068 }
cea2e8a9 1069 Perl_dump_indent(aTHX_ level-1, file, "}\n");
3967c732
JD		 1070}
1071
36b1c95c
MH		 1072/*
1073=for apidoc op_dump
1074
1075Dumps the optree starting at OP C<o> to C<STDERR>.
1076
1077=cut
1078*/
1079
3967c732 1080void
6867be6d 1081Perl_op_dump(pTHX_ const OP *o)
3967c732 1082{
7918f24d 1083 PERL_ARGS_ASSERT_OP_DUMP;
3967c732 1084 do_op_dump(0, Perl_debug_log, o);
8d063cd8
LW		 1085}
1086
8adcabd8 1087void
864dbfa3 1088Perl_gv_dump(pTHX_ GV *gv)
378cc40b 1089{
0eb335df
BF		 1090 STRLEN len;
1091 const char* name;
1092 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1093
79072805 1094 if (!gv) {
760ac839 1095 PerlIO_printf(Perl_debug_log, "{}\n");
378cc40b
LW		 1096 return;
1097 }
8990e307 1098 sv = sv_newmortal();
760ac839 1099 PerlIO_printf(Perl_debug_log, "{\n");
bd61b366 1100 gv_fullname3(sv, gv, NULL);
0eb335df
BF		 1101 name = SvPV_const(sv, len);
1102 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1103 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
79072805 1104 if (gv != GvEGV(gv)) {
bd61b366 1105 gv_efullname3(sv, GvEGV(gv), NULL);
0eb335df
BF		 1106 name = SvPV_const(sv, len);
1107 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1108 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
8adcabd8 1109 }
38d7fd8b 1110 (void)PerlIO_putc(Perl_debug_log, '\n');
cea2e8a9 1111 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
8d063cd8
LW		 1112}
1113
14befaf4 1114
afe38520 1115/* map magic types to the symbolic names
14befaf4
DM		 1116 * (with the PERL_MAGIC_ prefixed stripped)
1117 */
1118
27da23d5 1119static const struct { const char type; const char *name; } magic_names[] = {
16bc0f48 1120#include "mg_names.inc"
516a5887 1121 /* this null string terminates the list */
b9ac451d 1122 { 0, NULL },
14befaf4
DM		 1123};
1124
8adcabd8 1125void
6867be6d 1126Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
8d063cd8 1127{
7918f24d
NC		 1128 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1129
3967c732 1130 for (; mg; mg = mg->mg_moremagic) {
b900a521
JH		 1131 Perl_dump_indent(aTHX_ level, file,
1132 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
3967c732 1133 if (mg->mg_virtual) {
bfed75c6 1134 const MGVTBL * const v = mg->mg_virtual;
2d1f1fe5
NC		 1135 if (v >= PL_magic_vtables
1136 && v < PL_magic_vtables + magic_vtable_max) {
1137 const U32 i = v - PL_magic_vtables;
1138 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1139 }
3967c732 1140 else
b900a521 1141 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
3967c732
JD		 1142 }
1143 else
cea2e8a9 1144 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
8d063cd8 1145
3967c732 1146 if (mg->mg_private)
cea2e8a9 1147 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
3967c732 1148
14befaf4
DM		 1149 {
1150 int n;
c445ea15 1151 const char *name = NULL;
27da23d5 1152 for (n = 0; magic_names[n].name; n++) {
14befaf4
DM		 1153 if (mg->mg_type == magic_names[n].type) {
1154 name = magic_names[n].name;
1155 break;
1156 }
1157 }
1158 if (name)
1159 Perl_dump_indent(aTHX_ level, file,
1160 " MG_TYPE = PERL_MAGIC_%s\n", name);
1161 else
1162 Perl_dump_indent(aTHX_ level, file,
1163 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1164 }
3967c732
JD		 1165
1166 if (mg->mg_flags) {
cea2e8a9 1167 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
cb50f42d
YST		 1168 if (mg->mg_type == PERL_MAGIC_envelem &&
1169 mg->mg_flags & MGf_TAINTEDDIR)
cea2e8a9 1170 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
4c02285a
FR		 1171 if (mg->mg_type == PERL_MAGIC_regex_global &&
1172 mg->mg_flags & MGf_MINMATCH)
1173 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
3967c732 1174 if (mg->mg_flags & MGf_REFCOUNTED)
cea2e8a9 1175 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1176 if (mg->mg_flags & MGf_GSKIP)
cea2e8a9 1177 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
4c02285a
FR		 1178 if (mg->mg_flags & MGf_COPY)
1179 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1180 if (mg->mg_flags & MGf_DUP)
1181 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1182 if (mg->mg_flags & MGf_LOCAL)
1183 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
25fdce4a
FC		 1184 if (mg->mg_type == PERL_MAGIC_regex_global &&
1185 mg->mg_flags & MGf_BYTES)
1186 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
3967c732
JD		 1187 }
1188 if (mg->mg_obj) {
4c02285a 1189 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
28d8d7f4
YO		 1190 PTR2UV(mg->mg_obj));
1191 if (mg->mg_type == PERL_MAGIC_qr) {
07bc277f 1192 REGEXP* const re = (REGEXP *)mg->mg_obj;
61f9802b 1193 SV * const dsv = sv_newmortal();
866c78d1 1194 const char * const s
4c02285a 1195 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
28d8d7f4 1196 60, NULL, NULL,
95b611b0 1197 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
3c8556c3 1198 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
28d8d7f4 1199 );
6483fb35
RGS		 1200 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1201 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
07bc277f 1202 (IV)RX_REFCNT(re));
28d8d7f4
YO		 1203 }
1204 if (mg->mg_flags & MGf_REFCOUNTED)
3967c732
JD		 1205 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1206 }
1207 if (mg->mg_len)
894356b3 1208 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1209 if (mg->mg_ptr) {
b900a521 1210 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
3967c732 1211 if (mg->mg_len >= 0) {
7e8c5dac 1212 if (mg->mg_type != PERL_MAGIC_utf8) {
17605be7 1213 SV * const sv = newSVpvs("");
7e8c5dac 1214 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
17605be7 1215 SvREFCNT_dec_NN(sv);
7e8c5dac 1216 }
3967c732
JD		 1217 }
1218 else if (mg->mg_len == HEf_SVKEY) {
1219 PerlIO_puts(file, " => HEf_SVKEY\n");
ad64d0ec
NC		 1220 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1221 maxnest, dumpops, pvlim); /* MG is already +1 */
3967c732
JD		 1222 continue;
1223 }
866f9d6c 1224 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
3967c732 1225 else
866f9d6c
FC		 1226 PerlIO_puts(
1227 file,
1228 " ???? - " __FILE__
1229 " does not know how to handle this MG_LEN"
1230 );
38d7fd8b 1231 (void)PerlIO_putc(file, '\n');
3967c732 1232 }
7e8c5dac 1233 if (mg->mg_type == PERL_MAGIC_utf8) {
61f9802b 1234 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7e8c5dac
HS		 1235 if (cache) {
1236 IV i;
1237 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1238 Perl_dump_indent(aTHX_ level, file,
1239 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1240 i,
1241 (UV)cache[i * 2],
1242 (UV)cache[i * 2 + 1]);
1243 }
1244 }
378cc40b 1245 }
3967c732
JD		 1246}
1247
1248void
6867be6d 1249Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1250{
b9ac451d 1251 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732
JD		 1252}
1253
1254void
e1ec3a88 1255Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1256{
bfcb3514 1257 const char *hvname;
7918f24d
NC		 1258
1259 PERL_ARGS_ASSERT_DO_HV_DUMP;
1260
b900a521 1261 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
bfcb3514 1262 if (sv && (hvname = HvNAME_get(sv)))
d7d51f4b
YO		 1263 {
1264 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1265 name which quite legally could contain insane things like tabs, newlines, nulls or
1266 other scary crap - this should produce sane results - except maybe for unicode package
1267 names - but we will wait for someone to file a bug on that - demerphq */
0eb335df
BF		 1268 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1269 PerlIO_printf(file, "\t\"%s\"\n",
1270 generic_pv_escape( tmpsv, hvname,
1271 HvNAMELEN(sv), HvNAMEUTF8(sv)));
d7d51f4b 1272 }
79072805 1273 else
38d7fd8b 1274 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1275}
1276
1277void
e1ec3a88 1278Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1279{
7918f24d
NC		 1280 PERL_ARGS_ASSERT_DO_GV_DUMP;
1281
b900a521 1282 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
0eb335df
BF		 1283 if (sv && GvNAME(sv)) {
1284 SV * const tmpsv = newSVpvs("");
1285 PerlIO_printf(file, "\t\"%s\"\n",
1286 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1287 }
c90c0ff4 1288 else
38d7fd8b 1289 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1290}
1291
1292void
e1ec3a88 1293Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1294{
7918f24d
NC		 1295 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1296
b900a521 1297 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732 1298 if (sv && GvNAME(sv)) {
0eb335df 1299 SV *tmp = newSVpvs_flags("", SVs_TEMP);
bfcb3514 1300 const char *hvname;
0eb335df
BF		 1301 HV * const stash = GvSTASH(sv);
1302 PerlIO_printf(file, "\t");
1303 /* TODO might have an extra \" here */
1304 if (stash && (hvname = HvNAME_get(stash))) {
1305 PerlIO_printf(file, "\"%s\" :: \"",
1306 generic_pv_escape(tmp, hvname,
1307 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1308 }
1309 PerlIO_printf(file, "%s\"\n",
1310 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
8d063cd8 1311 }
3967c732 1312 else
38d7fd8b 1313 (void)PerlIO_putc(file, '\n');
3967c732
JD		 1314}
1315
a0c2f4dd
NC		 1316const struct flag_to_name first_sv_flags_names[] = {
1317 {SVs_TEMP, "TEMP,"},
1318 {SVs_OBJECT, "OBJECT,"},
1319 {SVs_GMG, "GMG,"},
1320 {SVs_SMG, "SMG,"},
1321 {SVs_RMG, "RMG,"},
1322 {SVf_IOK, "IOK,"},
1323 {SVf_NOK, "NOK,"},
1324 {SVf_POK, "POK,"}
1325};
1326
1327const struct flag_to_name second_sv_flags_names[] = {
1328 {SVf_OOK, "OOK,"},
1329 {SVf_FAKE, "FAKE,"},
1330 {SVf_READONLY, "READONLY,"},
fd01b4b7 1331 {SVf_PROTECT, "PROTECT,"},
a0c2f4dd 1332 {SVf_BREAK, "BREAK,"},
a0c2f4dd
NC		 1333 {SVp_IOK, "pIOK,"},
1334 {SVp_NOK, "pNOK,"},
1335 {SVp_POK, "pPOK,"}
1336};
1337
ae1f06a1
NC		 1338const struct flag_to_name cv_flags_names[] = {
1339 {CVf_ANON, "ANON,"},
1340 {CVf_UNIQUE, "UNIQUE,"},
1341 {CVf_CLONE, "CLONE,"},
1342 {CVf_CLONED, "CLONED,"},
1343 {CVf_CONST, "CONST,"},
1344 {CVf_NODEBUG, "NODEBUG,"},
1345 {CVf_LVALUE, "LVALUE,"},
1346 {CVf_METHOD, "METHOD,"},
cfc1e951 1347 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1348 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1349 {CVf_DYNFILE, "DYNFILE,"},
8fa6a409 1350 {CVf_AUTOLOAD, "AUTOLOAD,"},
e4555ecf 1351 {CVf_HASEVAL, "HASEVAL,"},
bfbc3ad9 1352 {CVf_SLABBED, "SLABBED,"},
bf9a4d2d 1353 {CVf_NAMED, "NAMED,"},
82487b59 1354 {CVf_LEXICAL, "LEXICAL,"},
31d45e0c 1355 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC		 1356};
1357
1358const struct flag_to_name hv_flags_names[] = {
1359 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1360 {SVphv_LAZYDEL, "LAZYDEL,"},
1361 {SVphv_HASKFLAGS, "HASKFLAGS,"},
45eaf8af 1362 {SVf_AMAGIC, "OVERLOAD,"},
ae1f06a1
NC		 1363 {SVphv_CLONEABLE, "CLONEABLE,"}
1364};
1365
1366const struct flag_to_name gp_flags_names[] = {
1367 {GVf_INTRO, "INTRO,"},
1368 {GVf_MULTI, "MULTI,"},
1369 {GVf_ASSUMECV, "ASSUMECV,"},
ae1f06a1
NC		 1370};
1371
1372const struct flag_to_name gp_flags_imported_names[] = {
1373 {GVf_IMPORTED_SV, " SV"},
1374 {GVf_IMPORTED_AV, " AV"},
1375 {GVf_IMPORTED_HV, " HV"},
1376 {GVf_IMPORTED_CV, " CV"},
1377};
1378
0d331aaf
YO		 1379/* NOTE: this structure is mostly duplicative of one generated by
1380 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1381 * the two. - Yves */
e3e400ec 1382const struct flag_to_name regexp_extflags_names[] = {
d63e6659
DM		 1383 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1384 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1385 {RXf_PMf_FOLD, "PMf_FOLD,"},
1386 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
334afb3e 1387 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
d63e6659 1388 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
41d7c59e 1389 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
8e1490ee 1390 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
dbc200c5 1391 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
d63e6659 1392 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
d63e6659
DM		 1393 {RXf_CHECK_ALL, "CHECK_ALL,"},
1394 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1395 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1396 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1397 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
dbc200c5 1398 {RXf_SPLIT, "SPLIT,"},
d63e6659
DM		 1399 {RXf_COPY_DONE, "COPY_DONE,"},
1400 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1401 {RXf_TAINTED, "TAINTED,"},
1402 {RXf_START_ONLY, "START_ONLY,"},
dbc200c5 1403 {RXf_SKIPWHITE, "SKIPWHITE,"},
d63e6659
DM		 1404 {RXf_WHITE, "WHITE,"},
1405 {RXf_NULL, "NULL,"},
1406};
1407
0d331aaf
YO		 1408/* NOTE: this structure is mostly duplicative of one generated by
1409 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1410 * the two. - Yves */
e3e400ec
YO		 1411const struct flag_to_name regexp_core_intflags_names[] = {
1412 {PREGf_SKIP, "SKIP,"},
0d331aaf
YO		 1413 {PREGf_IMPLICIT, "IMPLICIT,"},
1414 {PREGf_NAUGHTY, "NAUGHTY,"},
e3e400ec
YO		 1415 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1416 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
0d331aaf 1417 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
e3e400ec 1418 {PREGf_NOSCAN, "NOSCAN,"},
58430ea8
YO		 1419 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1420 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
8e1490ee
YO		 1421 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1422 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1423 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
e3e400ec
YO		 1424};
1425
c24d0595
DM		 1426/* Perl_do_sv_dump():
1427 *
1428 * level: amount to indent the output
1429 * sv: the object to dump
1430 * nest: the current level of recursion
1431 * maxnest: the maximum allowed level of recursion
1432 * dumpops: if true, also dump the ops associated with a CV
1433 * pvlim: limit on the length of any strings that are output
1434 * */
1435
3967c732 1436void
864dbfa3 1437Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1438{
cea89e20 1439 SV *d;
e1ec3a88 1440 const char *s;
3967c732
JD		 1441 U32 flags;
1442 U32 type;
1443
7918f24d
NC		 1444 PERL_ARGS_ASSERT_DO_SV_DUMP;
1445
3967c732 1446 if (!sv) {
cea2e8a9 1447 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1448 return;
378cc40b 1449 }
2ef28da1 1450
3967c732
JD		 1451 flags = SvFLAGS(sv);
1452 type = SvTYPE(sv);
79072805 1453
e0bbf362
DM		 1454 /* process general SV flags */
1455
cea89e20 1456 d = Perl_newSVpvf(aTHX_
57def98f 1457 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
56431972 1458 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS		 1459 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1460 (int)(PL_dumpindent*level), "");
8d063cd8 1461
0f94cb1f 1462 if ((flags & SVs_PADSTALE))
9a214eec 1463 sv_catpv(d, "PADSTALE,");
0f94cb1f 1464 if ((flags & SVs_PADTMP))
9a214eec 1465 sv_catpv(d, "PADTMP,");
a0c2f4dd 1466 append_flags(d, flags, first_sv_flags_names);
810b8aa5
GS		 1467 if (flags & SVf_ROK) {
1468 sv_catpv(d, "ROK,");
1469 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1470 }
45eaf8af 1471 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
a0c2f4dd 1472 append_flags(d, flags, second_sv_flags_names);
7db6405c
FC		 1473 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1474 && type != SVt_PVAV) {
1ccdb730
NC		 1475 if (SvPCS_IMPORTED(sv))
1476 sv_catpv(d, "PCS_IMPORTED,");
1477 else
9660f481 1478 sv_catpv(d, "SCREAM,");
1ccdb730 1479 }
3967c732 1480
e0bbf362
DM		 1481 /* process type-specific SV flags */
1482
3967c732
JD		 1483 switch (type) {
1484 case SVt_PVCV:
1485 case SVt_PVFM:
ae1f06a1 1486 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD		 1487 break;
1488 case SVt_PVHV:
ae1f06a1 1489 append_flags(d, flags, hv_flags_names);
3967c732 1490 break;
926fc7b6
DM		 1491 case SVt_PVGV:
1492 case SVt_PVLV:
1493 if (isGV_with_GP(sv)) {
ae1f06a1 1494 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1495 }
926fc7b6 1496 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD		 1497 sv_catpv(d, "IMPORT");
1498 if (GvIMPORTED(sv) == GVf_IMPORTED)
1499 sv_catpv(d, "ALL,");
1500 else {
1501 sv_catpv(d, "(");
ae1f06a1 1502 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
3967c732
JD		 1503 sv_catpv(d, " ),");
1504 }
1505 }
924ba076 1506 /* FALLTHROUGH */
25da4f38 1507 default:
e604303a 1508 evaled_or_uv:
25da4f38 1509 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
69c678eb 1510 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1511 break;
addd1794 1512 case SVt_PVMG:
c13a5c80
NC		 1513 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1514 if (SvVALID(sv)) sv_catpv(d, "VALID,");
924ba076 1515 /* FALLTHROUGH */
e604303a 1516 goto evaled_or_uv;
11ca45c0
NC		 1517 case SVt_PVAV:
1518 break;
3967c732 1519 }
86f0d186
NC		 1520 /* SVphv_SHAREKEYS is also 0x20000000 */
1521 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1522 sv_catpv(d, "UTF8");
3967c732 1523
b162af07
SP		 1524 if (*(SvEND(d) - 1) == ',') {
1525 SvCUR_set(d, SvCUR(d) - 1);
1526 SvPVX(d)[SvCUR(d)] = '\0';
1527 }
3967c732 1528 sv_catpv(d, ")");
b15aece3 1529 s = SvPVX_const(d);
3967c732 1530
e0bbf362
DM		 1531 /* dump initial SV details */
1532
fd0854ff 1533#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1534 Perl_dump_indent(aTHX_ level, file,
cd676548 1535 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
fd0854ff
DM		 1536 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1537 sv->sv_debug_line,
1538 sv->sv_debug_inpad ? "for" : "by",
1539 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1540 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM		 1541 sv->sv_debug_serial
1542 );
fd0854ff 1543#endif
cea2e8a9 1544 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM		 1545
1546 /* Dump SV type */
1547
5357ca29
NC		 1548 if (type < SVt_LAST) {
1549 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1550
1551 if (type == SVt_NULL) {
5f954473 1552 SvREFCNT_dec_NN(d);
5357ca29
NC		 1553 return;
1554 }
1555 } else {
faccc32b 1556 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
5f954473 1557 SvREFCNT_dec_NN(d);
3967c732
JD		 1558 return;
1559 }
e0bbf362
DM		 1560
1561 /* Dump general SV fields */
1562
27bd069f 1563 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC		 1564 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1565 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1566 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1567 if (SvIsUV(sv)
765f542d 1568 )
57def98f 1569 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1570 else
57def98f 1571 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
38d7fd8b 1572 (void)PerlIO_putc(file, '\n');
3967c732 1573 }
e0bbf362 1574
0f94cb1f 1575 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1576 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1577 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1578 || type == SVt_NV) {
67d796ae 1579 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
88cb8500 1580 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
67d796ae 1581 RESTORE_LC_NUMERIC_UNDERLYING();
3967c732 1582 }
e0bbf362 1583
3967c732 1584 if (SvROK(sv)) {
57def98f 1585 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732
JD		 1586 if (nest < maxnest)
1587 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1588 }
e0bbf362 1589
cea89e20 1590 if (type < SVt_PV) {
5f954473 1591 SvREFCNT_dec_NN(d);
3967c732 1592 return;
cea89e20 1593 }
e0bbf362 1594
5a3c7349
FC		 1595 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1596 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
8d919b0a
FC		 1597 const bool re = isREGEXP(sv);
1598 const char * const ptr =
1599 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1600 if (ptr) {
69240efd 1601 STRLEN delta;
7a4bba22 1602 if (SvOOK(sv)) {
69240efd 1603 SvOOK_offset(sv, delta);
7a4bba22 1604 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
5186cc12 1605 (UV) delta);
69240efd
NC		 1606 } else {
1607 delta = 0;
7a4bba22 1608 }
8d919b0a 1609 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
7a4bba22
NC		 1610 if (SvOOK(sv)) {
1611 PerlIO_printf(file, "( %s . ) ",
8d919b0a 1612 pv_display(d, ptr - delta, delta, 0,
7a4bba22
NC		 1613 pvlim));
1614 }
ad3f05ad
KW		 1615 if (type == SVt_INVLIST) {
1616 PerlIO_printf(file, "\n");
1617 /* 4 blanks indents 2 beyond the PV, etc */
1618 _invlist_dump(file, level, " ", sv);
1619 }
1620 else {
685bfc3c
KW		 1621 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1622 re ? 0 : SvLEN(sv),
1623 pvlim));
1624 if (SvUTF8(sv)) /* the 6? \x{....} */
1625 PerlIO_printf(file, " [UTF8 \"%s\"]",
1626 sv_uni_display(d, sv, 6 * SvCUR(sv),
1627 UNI_DISPLAY_QQ));
1628 PerlIO_printf(file, "\n");
ad3f05ad 1629 }
57def98f 1630 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
8d919b0a
FC		 1631 if (!re)
1632 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1633 (IV)SvLEN(sv));
93c10d60 1634#ifdef PERL_COPY_ON_WRITE
db2c6cb3
FC		 1635 if (SvIsCOW(sv) && SvLEN(sv))
1636 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1637 CowREFCNT(sv));
1638#endif
3967c732
JD		 1639 }
1640 else
cea2e8a9 1641 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1642 }
e0bbf362 1643
3967c732 1644 if (type >= SVt_PVMG) {
0f94cb1f 1645 if (SvMAGIC(sv))
8530ff28 1646 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
3967c732
JD		 1647 if (SvSTASH(sv))
1648 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC		 1649
1650 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
c13a5c80
NC		 1651 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1652 }
3967c732 1653 }
e0bbf362
DM		 1654
1655 /* Dump type-specific SV fields */
1656
3967c732 1657 switch (type) {
3967c732 1658 case SVt_PVAV:
57def98f 1659 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1660 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f
JH		 1661 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1662 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732
JD		 1663 }
1664 else
38d7fd8b 1665 (void)PerlIO_putc(file, '\n');
57def98f
JH		 1666 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1667 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
9b7476d7 1668 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
7db6405c 1669 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
76f68e9b 1670 sv_setpvs(d, "");
11ca45c0
NC		 1671 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1672 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP		 1673 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1674 SvCUR(d) ? SvPVX_const(d) + 1 : "");
b9f2b683 1675 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
c70927a6 1676 SSize_t count;
b9f2b683 1677 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
502c6561 1678 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
3967c732 1679
57def98f 1680 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
2ef28da1 1681 if (elt)
3967c732
JD		 1682 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1683 }
1684 }
1685 break;
5d27ee4a
DD		 1686 case SVt_PVHV: {
1687 U32 usedkeys;
0c22a733
DM		 1688 if (SvOOK(sv)) {
1689 struct xpvhv_aux *const aux = HvAUX(sv);
1690 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1691 (UV)aux->xhv_aux_flags);
1692 }
57def98f 1693 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
5d27ee4a
DD		 1694 usedkeys = HvUSEDKEYS(sv);
1695 if (HvARRAY(sv) && usedkeys) {
3967c732
JD		 1696 /* Show distribution of HEs in the ARRAY */
1697 int freq[200];
c3caa5c3 1698#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
3967c732
JD		 1699 int i;
1700 int max = 0;
5d27ee4a 1701 U32 pow2 = 2, keys = usedkeys;
65202027 1702 NV theoret, sum = 0;
3967c732
JD		 1703
1704 PerlIO_printf(file, " (");
1705 Zero(freq, FREQ_MAX + 1, int);
eb160463 1706 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL		 1707 HE* h;
1708 int count = 0;
3967c732
JD		 1709 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1710 count++;
1711 if (count > FREQ_MAX)
1712 count = FREQ_MAX;
1713 freq[count]++;
1714 if (max < count)
1715 max = count;
1716 }
1717 for (i = 0; i <= max; i++) {
1718 if (freq[i]) {
1719 PerlIO_printf(file, "%d%s:%d", i,
1720 (i == FREQ_MAX) ? "+" : "",
1721 freq[i]);
1722 if (i != max)
1723 PerlIO_printf(file, ", ");
1724 }
1725 }
38d7fd8b 1726 (void)PerlIO_putc(file, ')');
b8fa94d8
MG		 1727 /* The "quality" of a hash is defined as the total number of
1728 comparisons needed to access every element once, relative
1729 to the expected number needed for a random hash.
1730
1731 The total number of comparisons is equal to the sum of
e76cd0fa
AMS		 1732 the squares of the number of entries in each bucket.
1733 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG		 1734 value is
1735 n + n(n-1)/2k
1736 */
1737
3967c732
JD		 1738 for (i = max; i > 0; i--) { /* Precision: count down. */
1739 sum += freq[i] * i * i;
1740 }
155aba94 1741 while ((keys = keys >> 1))
3967c732 1742 pow2 = pow2 << 1;
5d27ee4a 1743 theoret = usedkeys;
b8fa94d8 1744 theoret += theoret * (theoret-1)/pow2;
38d7fd8b 1745 (void)PerlIO_putc(file, '\n');
6b4667fc 1746 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732 1747 }
38d7fd8b 1748 (void)PerlIO_putc(file, '\n');
5d27ee4a 1749 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
9faf471a
NC		 1750 {
1751 STRLEN count = 0;
1752 HE **ents = HvARRAY(sv);
1753
1754 if (ents) {
1755 HE *const *const last = ents + HvMAX(sv);
1756 count = last + 1 - ents;
1757
1758 do {
1759 if (!*ents)
1760 --count;
1761 } while (++ents <= last);
1762 }
1763
1764 if (SvOOK(sv)) {
1765 struct xpvhv_aux *const aux = HvAUX(sv);
1766 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1767 " (cached = %"UVuf")\n",
1768 (UV)count, (UV)aux->xhv_fill_lazy);
1769 } else {
1770 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1771 (UV)count);
1772 }
1773 }
57def98f 1774 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
e1a7ec8d
YO		 1775 if (SvOOK(sv)) {
1776 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1777 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
6a5b4183 1778#ifdef PERL_HASH_RANDOMIZE_KEYS
e1a7ec8d
YO		 1779 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1780 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
6a5b4183 1781 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
e1a7ec8d 1782 }
6a5b4183 1783#endif
38d7fd8b 1784 (void)PerlIO_putc(file, '\n');
e1a7ec8d 1785 }
8d2f4536 1786 {
b9ac451d 1787 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536
NC		 1788 if (mg && mg->mg_obj) {
1789 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1790 }
1791 }
bfcb3514 1792 {
b9ac451d 1793 const char * const hvname = HvNAME_get(sv);
0eb335df
BF		 1794 if (hvname) {
1795 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1796 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1797 generic_pv_escape( tmpsv, hvname,
1798 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1799 }
bfcb3514 1800 }
86f55936 1801 if (SvOOK(sv)) {
ad64d0ec 1802 AV * const backrefs
85fbaab2 1803 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 1804 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC		 1805 if (HvAUX(sv)->xhv_name_count)
1806 Perl_dump_indent(aTHX_
7afc2217
FC		 1807 level, file, " NAMECOUNT = %"IVdf"\n",
1808 (IV)HvAUX(sv)->xhv_name_count
67e04715 1809 );
15d9236d 1810 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC		 1811 const I32 count = HvAUX(sv)->xhv_name_count;
1812 if (count) {
1813 SV * const names = newSVpvs_flags("", SVs_TEMP);
1814 /* The starting point is the first element if count is
1815 positive and the second element if count is negative. */
1816 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1817 + (count < 0 ? 1 : 0);
1818 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1819 + (count < 0 ? -count : count);
1820 while (hekp < endp) {
0eb335df
BF		 1821 if (HEK_LEN(*hekp)) {
1822 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1823 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1824 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
ec3405c8
NC		 1825 } else {
1826 /* This should never happen. */
1827 sv_catpvs(names, ", (null)");
67e04715 1828 }
ec3405c8
NC		 1829 ++hekp;
1830 }
67e04715
FC		 1831 Perl_dump_indent(aTHX_
1832 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1833 );
1834 }
0eb335df
BF		 1835 else {
1836 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1837 const char *const hvename = HvENAME_get(sv);
67e04715 1838 Perl_dump_indent(aTHX_
0eb335df
BF		 1839 level, file, " ENAME = \"%s\"\n",
1840 generic_pv_escape(tmp, hvename,
1841 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1842 }
67e04715 1843 }
86f55936
NC		 1844 if (backrefs) {
1845 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1846 PTR2UV(backrefs));
ad64d0ec 1847 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC		 1848 dumpops, pvlim);
1849 }
7d88e6c4 1850 if (meta) {
0eb335df
BF		 1851 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1852 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1853 generic_pv_escape( tmpsv, meta->mro_which->name,
1854 meta->mro_which->length,
1855 (meta->mro_which->kflags & HVhek_UTF8)),
7d88e6c4
NC		 1856 PTR2UV(meta->mro_which));
1857 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1858 (UV)meta->cache_gen);
1859 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1860 (UV)meta->pkg_gen);
1861 if (meta->mro_linear_all) {
1862 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1863 PTR2UV(meta->mro_linear_all));
1864 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1865 dumpops, pvlim);
1866 }
1867 if (meta->mro_linear_current) {
1868 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1869 PTR2UV(meta->mro_linear_current));
1870 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1871 dumpops, pvlim);
1872 }
1873 if (meta->mro_nextmethod) {
1874 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1875 PTR2UV(meta->mro_nextmethod));
1876 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1877 dumpops, pvlim);
1878 }
1879 if (meta->isa) {
1880 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1881 PTR2UV(meta->isa));
1882 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1883 dumpops, pvlim);
1884 }
1885 }
86f55936 1886 }
b5698553 1887 if (nest < maxnest) {
cbab3169 1888 HV * const hv = MUTABLE_HV(sv);
b5698553
TH		 1889 STRLEN i;
1890 HE *he;
cbab3169 1891
b5698553
TH		 1892 if (HvARRAY(hv)) {
1893 int count = maxnest - nest;
1894 for (i=0; i <= HvMAX(hv); i++) {
1895 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1896 U32 hash;
1897 SV * keysv;
1898 const char * keypv;
1899 SV * elt;
7dc86639 1900 STRLEN len;
b5698553
TH		 1901
1902 if (count-- <= 0) goto DONEHV;
1903
1904 hash = HeHASH(he);
1905 keysv = hv_iterkeysv(he);
1906 keypv = SvPV_const(keysv, len);
1907 elt = HeVAL(he);
cbab3169 1908
7dc86639
YO		 1909 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1910 if (SvUTF8(keysv))
1911 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH		 1912 if (HvEITER_get(hv) == he)
1913 PerlIO_printf(file, "[CURRENT] ");
7dc86639
YO		 1914 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1915 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1916 }
b5698553
TH		 1917 }
1918 DONEHV:;
1919 }
3967c732
JD		 1920 }
1921 break;
5d27ee4a 1922 } /* case SVt_PVHV */
e0bbf362 1923
3967c732 1924 case SVt_PVCV:
8fa6a409 1925 if (CvAUTOLOAD(sv)) {
0eb335df
BF		 1926 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1927 STRLEN len;
8fa6a409 1928 const char *const name = SvPV_const(sv, len);
0eb335df
BF		 1929 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1930 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
8fa6a409
FC		 1931 }
1932 if (SvPOK(sv)) {
0eb335df
BF		 1933 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1934 const char *const proto = CvPROTO(sv);
1935 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1936 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1937 SvUTF8(sv)));
cbf82dd0 1938 }
924ba076 1939 /* FALLTHROUGH */
3967c732
JD		 1940 case SVt_PVFM:
1941 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC		 1942 if (!CvISXSUB(sv)) {
1943 if (CvSTART(sv)) {
1944 Perl_dump_indent(aTHX_ level, file,
1945 " START = 0x%"UVxf" ===> %"IVdf"\n",
1946 PTR2UV(CvSTART(sv)),
1947 (IV)sequence_num(CvSTART(sv)));
1948 }
1949 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1950 PTR2UV(CvROOT(sv)));
1951 if (CvROOT(sv) && dumpops) {
1952 do_op_dump(level+1, file, CvROOT(sv));
1953 }
1954 } else {
126f53f3 1955 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 1956
d04ba589 1957 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099
NC		 1958
1959 if (constant) {
1960 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1961 " (CONST SV)\n",
1962 PTR2UV(CvXSUBANY(sv).any_ptr));
1963 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1964 pvlim);
1965 } else {
1966 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1967 (IV)CvXSUBANY(sv).any_i32);
1968 }
1969 }
3610c89f
FC		 1970 if (CvNAMED(sv))
1971 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1972 HEK_KEY(CvNAME_HEK((CV *)sv)));
1973 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1974 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
bb02a38f 1975 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 1976 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 1977 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
eacbb379
DD		 1978 if (!CvISXSUB(sv)) {
1979 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1980 if (nest < maxnest) {
1981 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1982 }
3967c732 1983 }
eacbb379 1984 else
db6e00bd 1985 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
3967c732 1986 {
b9ac451d 1987 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 1988 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 1989 PTR2UV(outside),
cf2093f6
JH		 1990 (!outside ? "null"
1991 : CvANON(outside) ? "ANON"
1992 : (outside == PL_main_cv) ? "MAIN"
1993 : CvUNIQUE(outside) ? "UNIQUE"
b24fda9d
BF		 1994 : CvGV(outside) ?
1995 generic_pv_escape(
1996 newSVpvs_flags("", SVs_TEMP),
1997 GvNAME(CvGV(outside)),
1998 GvNAMELEN(CvGV(outside)),
1999 GvNAMEUTF8(CvGV(outside)))
2000 : "UNDEFINED"));
3967c732 2001 }
704b97aa
FC		 2002 if (CvOUTSIDE(sv)
2003 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
ad64d0ec 2004 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2005 break;
e0bbf362 2006
926fc7b6
DM		 2007 case SVt_PVGV:
2008 case SVt_PVLV:
b9ac451d
AL		 2009 if (type == SVt_PVLV) {
2010 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2011 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2012 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2013 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
83f78d1a 2014 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
305b8651 2015 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
b9ac451d
AL		 2016 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2017 dumpops, pvlim);
2018 }
8d919b0a 2019 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM		 2020 if (!isGV_with_GP(sv))
2021 break;
0eb335df
BF		 2022 {
2023 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2024 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2025 generic_pv_escape(tmpsv, GvNAME(sv),
2026 GvNAMELEN(sv),
2027 GvNAMEUTF8(sv)));
2028 }
57def98f 2029 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 2030 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
be108a01 2031 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
57def98f 2032 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c
GS		 2033 if (!GvGP(sv))
2034 break;
57def98f
JH		 2035 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2036 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2037 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2038 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2039 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2040 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2041 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2042 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
008009b0
FC		 2043 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
2044 " (%s)\n",
2045 (UV)GvGPFLAGS(sv),
71afaece 2046 "");
57def98f 2047 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 2048 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
3967c732
JD		 2049 do_gv_dump (level, file, " EGV", GvEGV(sv));
2050 break;
2051 case SVt_PVIO:
57def98f
JH		 2052 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2053 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2054 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2055 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2056 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2057 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2058 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 2059 if (IoTOP_NAME(sv))
cea2e8a9 2060 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC		 2061 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2062 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2063 else {
2064 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2065 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC		 2066 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2067 maxnest, dumpops, pvlim);
9ba1f565
NC		 2068 }
2069 /* Source filters hide things that are not GVs in these three, so let's
2070 be careful out there. */
27533608 2071 if (IoFMT_NAME(sv))
cea2e8a9 2072 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC		 2073 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2074 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2075 else {
2076 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2077 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC		 2078 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2079 maxnest, dumpops, pvlim);
9ba1f565 2080 }
27533608 2081 if (IoBOTTOM_NAME(sv))
cea2e8a9 2082 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC		 2083 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2084 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2085 else {
2086 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2087 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC		 2088 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2089 maxnest, dumpops, pvlim);
9ba1f565 2090 }
27533608 2091 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2092 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2093 else
cea2e8a9 2094 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 2095 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732 2096 break;
206ee256 2097 case SVt_REGEXP:
8d919b0a 2098 dumpregexp:
d63e6659 2099 {
8d919b0a 2100 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO		 2101
2102#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2103 sv_setpv(d,""); \
e3e400ec 2104 append_flags(d, flags, names); \
ec16d31f
YO		 2105 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2106 SvCUR_set(d, SvCUR(d) - 1); \
2107 SvPVX(d)[SvCUR(d)] = '\0'; \
2108 } \
2109} STMT_END
e3e400ec 2110 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
dbc200c5
YO		 2111 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2112 (UV)(r->compflags), SvPVX_const(d));
2113
e3e400ec 2114 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
d63e6659 2115 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
dbc200c5
YO		 2116 (UV)(r->extflags), SvPVX_const(d));
2117
e3e400ec
YO		 2118 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2119 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2120 if (r->engine == &PL_core_reg_engine) {
2121 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2122 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2123 (UV)(r->intflags), SvPVX_const(d));
2124 } else {
2125 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
d63e6659 2126 (UV)(r->intflags));
e3e400ec
YO		 2127 }
2128#undef SV_SET_STRINGIFY_REGEXP_FLAGS
d63e6659
DM		 2129 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2130 (UV)(r->nparens));
2131 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2132 (UV)(r->lastparen));
2133 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2134 (UV)(r->lastcloseparen));
2135 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2136 (IV)(r->minlen));
2137 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2138 (IV)(r->minlenret));
2139 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2140 (UV)(r->gofs));
2141 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2142 (UV)(r->pre_prefix));
d63e6659
DM		 2143 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2144 (IV)(r->sublen));
6502e081
DM		 2145 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2146 (IV)(r->suboffset));
2147 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2148 (IV)(r->subcoffset));
d63e6659
DM		 2149 if (r->subbeg)
2150 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2151 PTR2UV(r->subbeg),
2152 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2153 else
2154 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
d63e6659
DM		 2155 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2156 PTR2UV(r->mother_re));
01ffd0f1
FC		 2157 if (nest < maxnest && r->mother_re)
2158 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2159 maxnest, dumpops, pvlim);
d63e6659
DM		 2160 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2161 PTR2UV(r->paren_names));
2162 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2163 PTR2UV(r->substrs));
2164 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2165 PTR2UV(r->pprivate));
2166 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2167 PTR2UV(r->offs));
d63c20f2
DM		 2168 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2169 PTR2UV(r->qr_anoncv));
db2c6cb3 2170#ifdef PERL_ANY_COW
d63e6659
DM		 2171 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2172 PTR2UV(r->saved_copy));
2173#endif
2174 }
206ee256 2175 break;
3967c732 2176 }
5f954473 2177 SvREFCNT_dec_NN(d);
3967c732
JD		 2178}
2179
36b1c95c
MH		 2180/*
2181=for apidoc sv_dump
2182
2183Dumps the contents of an SV to the C<STDERR> filehandle.
2184
2185For an example of its output, see L<Devel::Peek>.
2186
2187=cut
2188*/
2189
3967c732 2190void
864dbfa3 2191Perl_sv_dump(pTHX_ SV *sv)
3967c732 2192{
7918f24d
NC		 2193 PERL_ARGS_ASSERT_SV_DUMP;
2194
d1029faa
JP		 2195 if (SvROK(sv))
2196 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2197 else
2198 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2199}
bd16a5f0
IZ		 2200
2201int
2202Perl_runops_debug(pTHX)
2203{
2204 if (!PL_op) {
9b387841 2205 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ		 2206 return 0;
2207 }
2208
9f3673fb 2209 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2210 do {
75d476e2
S		 2211#ifdef PERL_TRACE_OPS
2212 ++PL_op_exec_cnt[PL_op->op_type];
2213#endif
bd16a5f0 2214 if (PL_debug) {
991bab54
DM		 2215 ENTER;
2216 SAVETMPS;
b9ac451d 2217 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0
IZ		 2218 PerlIO_printf(Perl_debug_log,
2219 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2220 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2221 PTR2UV(*PL_watchaddr));
d6721266
DM		 2222 if (DEBUG_s_TEST_) {
2223 if (DEBUG_v_TEST_) {
2224 PerlIO_printf(Perl_debug_log, "\n");
2225 deb_stack_all();
2226 }
2227 else
2228 debstack();
2229 }
2230
2231
bd16a5f0
IZ		 2232 if (DEBUG_t_TEST_) debop(PL_op);
2233 if (DEBUG_P_TEST_) debprof(PL_op);
991bab54
DM		 2234 FREETMPS;
2235 LEAVE;
bd16a5f0 2236 }
fe83c362
SM		 2237
2238 OP_ENTRY_PROBE(OP_NAME(PL_op));
16c91539 2239 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2240 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2241 PERL_ASYNC_CHECK();
bd16a5f0
IZ		 2242
2243 TAINT_NOT;
2244 return 0;
2245}
2246
f9b02e42
DM		 2247
2248/* print the names of the n lexical vars starting at pad offset off */
2249
f9db5646 2250STATIC void
f9b02e42
DM		 2251S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2252{
2253 PADNAME *sv;
2254 CV * const cv = deb_curcv(cxstack_ix);
2255 PADNAMELIST *comppad = NULL;
2256 int i;
2257
2258 if (cv) {
2259 PADLIST * const padlist = CvPADLIST(cv);
2260 comppad = PadlistNAMES(padlist);
2261 }
2262 if (paren)
2263 PerlIO_printf(Perl_debug_log, "(");
2264 for (i = 0; i < n; i++) {
2265 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2266 PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2267 else
2268 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2269 (UV)(off+i));
2270 if (i < n - 1)
2271 PerlIO_printf(Perl_debug_log, ",");
2272 }
2273 if (paren)
2274 PerlIO_printf(Perl_debug_log, ")");
2275}
2276
2277
fedf30e1
DM		 2278/* append to the out SV, the name of the lexical at offset off in the CV
2279 * cv */
2280
ec48399d 2281static void
fedf30e1
DM		 2282S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2283 bool paren, bool is_scalar)
2284{
2285 PADNAME *sv;
2286 PADNAMELIST *namepad = NULL;
2287 int i;
2288
2289 if (cv) {
2290 PADLIST * const padlist = CvPADLIST(cv);
2291 namepad = PadlistNAMES(padlist);
2292 }
2293
2294 if (paren)
2295 sv_catpvs_nomg(out, "(");
2296 for (i = 0; i < n; i++) {
2297 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2298 {
2299 STRLEN cur = SvCUR(out);
26334c4d
FC		 2300 Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2301 UTF8fARG(1, PadnameLEN(sv) - 1,
2302 PadnamePV(sv) + 1));
fedf30e1
DM		 2303 if (is_scalar)
2304 SvPVX(out)[cur] = '$';
2305 }
2306 else
2307 Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2308 if (i < n - 1)
2309 sv_catpvs_nomg(out, ",");
2310 }
2311 if (paren)
2312 sv_catpvs_nomg(out, "(");
2313}
2314
2315
ec48399d 2316static void
8bbe2fa8 2317S_append_gv_name(pTHX_ GV *gv, SV *out)
fedf30e1
DM		 2318{
2319 SV *sv;
2320 if (!gv) {
2321 sv_catpvs_nomg(out, "<NULLGV>");
2322 return;
2323 }
2324 sv = newSV(0);
2325 gv_fullname4(sv, gv, NULL, FALSE);
ac892e4a 2326 Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv));
fedf30e1
DM		 2327 SvREFCNT_dec_NN(sv);
2328}
2329
2330#ifdef USE_ITHREADS
dc3c1c70
DM		 2331# define ITEM_SV(item) (comppad ? \
2332 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL);
fedf30e1
DM		 2333#else
2334# define ITEM_SV(item) UNOP_AUX_item_sv(item)
2335#endif
2336
2337
2338/* return a temporary SV containing a stringified representation of
48ee9c0e 2339 * the op_aux field of a MULTIDEREF op, associated with CV cv
fedf30e1
DM		 2340 */
2341
2342SV*
48ee9c0e 2343Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
fedf30e1
DM		 2344{
2345 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2346 UV actions = items->uv;
2347 SV *sv;
2348 bool last = 0;
2349 bool is_hash = FALSE;
2350 int derefs = 0;
ff94d24c 2351 SV *out = newSVpvn_flags("",0,SVs_TEMP);
fedf30e1 2352#ifdef USE_ITHREADS
dc3c1c70
DM		 2353 PAD *comppad;
2354
2355 if (cv) {
2356 PADLIST *padlist = CvPADLIST(cv);
2357 comppad = PadlistARRAY(padlist)[1];
2358 }
2359 else
2360 comppad = NULL;
fedf30e1
DM		 2361#endif
2362
48ee9c0e 2363 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
fedf30e1
DM		 2364
2365 while (!last) {
2366 switch (actions & MDEREF_ACTION_MASK) {
2367
2368 case MDEREF_reload:
2369 actions = (++items)->uv;
2370 continue;
2b5060ae 2371 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2372
2373 case MDEREF_HV_padhv_helem:
2374 is_hash = TRUE;
2b5060ae 2375 /* FALLTHROUGH */
fedf30e1
DM		 2376 case MDEREF_AV_padav_aelem:
2377 derefs = 1;
2378 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2379 goto do_elem;
2b5060ae 2380 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2381
2382 case MDEREF_HV_gvhv_helem:
2383 is_hash = TRUE;
2b5060ae 2384 /* FALLTHROUGH */
fedf30e1
DM		 2385 case MDEREF_AV_gvav_aelem:
2386 derefs = 1;
dc3c1c70
DM		 2387 items++;
2388 sv = ITEM_SV(items);
8bbe2fa8 2389 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2390 goto do_elem;
2b5060ae 2391 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2392
2393 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2394 is_hash = TRUE;
2b5060ae 2395 /* FALLTHROUGH */
fedf30e1 2396 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
dc3c1c70
DM		 2397 items++;
2398 sv = ITEM_SV(items);
8bbe2fa8 2399 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1 2400 goto do_vivify_rv2xv_elem;
2b5060ae 2401 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2402
2403 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2404 is_hash = TRUE;
2b5060ae 2405 /* FALLTHROUGH */
fedf30e1
DM		 2406 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2407 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2408 goto do_vivify_rv2xv_elem;
2b5060ae 2409 NOT_REACHED; /* NOTREACHED */
fedf30e1
DM		 2410
2411 case MDEREF_HV_pop_rv2hv_helem:
2412 case MDEREF_HV_vivify_rv2hv_helem:
2413 is_hash = TRUE;
2b5060ae 2414 /* FALLTHROUGH */
fedf30e1
DM		 2415 do_vivify_rv2xv_elem:
2416 case MDEREF_AV_pop_rv2av_aelem:
2417 case MDEREF_AV_vivify_rv2av_aelem:
2418 if (!derefs++)
2419 sv_catpvs_nomg(out, "->");
2420 do_elem:
2421 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2422 sv_catpvs_nomg(out, "->");
2423 last = 1;
2424 break;
2425 }
2426
2427 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2428 switch (actions & MDEREF_INDEX_MASK) {
2429 case MDEREF_INDEX_const:
2430 if (is_hash) {
dc3c1c70
DM		 2431 items++;
2432 sv = ITEM_SV(items);
2433 if (!sv)
2434 sv_catpvs_nomg(out, "???");
2435 else {
2436 STRLEN cur;
2437 char *s;
2438 s = SvPV(sv, cur);
2439 pv_pretty(out, s, cur, 30,
2440 NULL, NULL,
2441 (PERL_PV_PRETTY_NOCLEAR
2442 |PERL_PV_PRETTY_QUOTE
2443 |PERL_PV_PRETTY_ELLIPSES));
2444 }
fedf30e1
DM		 2445 }
2446 else
2447 Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2448 break;
2449 case MDEREF_INDEX_padsv:
2450 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2451 break;
2452 case MDEREF_INDEX_gvsv:
dc3c1c70
DM		 2453 items++;
2454 sv = ITEM_SV(items);
8bbe2fa8 2455 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM		 2456 break;
2457 }
2458 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2459
2460 if (actions & MDEREF_FLAG_last)
2461 last = 1;
2462 is_hash = FALSE;
2463
2464 break;
2465
2466 default:
2467 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2468 (int)(actions & MDEREF_ACTION_MASK));
2469 last = 1;
2470 break;
2471
2472 } /* switch */
2473
2474 actions >>= MDEREF_SHIFT;
2475 } /* while */
2476 return out;
2477}
2478
2479
bd16a5f0 2480I32
6867be6d 2481Perl_debop(pTHX_ const OP *o)
bd16a5f0 2482{
7918f24d
NC		 2483 PERL_ARGS_ASSERT_DEBOP;
2484
1045810a
IZ		 2485 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2486 return 0;
2487
bd16a5f0
IZ		 2488 Perl_deb(aTHX_ "%s", OP_NAME(o));
2489 switch (o->op_type) {
2490 case OP_CONST:
996c9baa 2491 case OP_HINTSEVAL:
6cefa69e 2492 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2493 * may not be active here, so check.
6cefa69e 2494 * Looks like only during compiling the pads are illegal.
7367e658 2495 */
6cefa69e
RU		 2496#ifdef USE_ITHREADS
2497 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2498#endif
7367e658 2499 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ		 2500 break;
2501 case OP_GVSV:
2502 case OP_GV:
8333ca1a 2503 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
b9ac451d 2504 SV * const sv = newSV(0);
bd61b366 2505 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2506 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
5f954473 2507 SvREFCNT_dec_NN(sv);
bd16a5f0 2508 }
8333ca1a
FC		 2509 else if (cGVOPo_gv) {
2510 SV * const sv = newSV(0);
2511 assert(SvROK(cGVOPo_gv));
2512 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2513 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
ecf05a58 2514 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
8333ca1a
FC		 2515 SvREFCNT_dec_NN(sv);
2516 }
bd16a5f0
IZ		 2517 else
2518 PerlIO_printf(Perl_debug_log, "(NULL)");
2519 break;
a7fd8ef6 2520
bd16a5f0
IZ		 2521 case OP_PADSV:
2522 case OP_PADAV:
2523 case OP_PADHV:
f9b02e42
DM		 2524 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2525 break;
fedf30e1 2526
a7fd8ef6 2527 case OP_PADRANGE:
f9b02e42
DM		 2528 S_deb_padvar(aTHX_ o->op_targ,
2529 o->op_private & OPpPADRANGE_COUNTMASK, 1);
bd16a5f0 2530 break;
a7fd8ef6 2531
fedf30e1 2532 case OP_MULTIDEREF:
ac892e4a
DM		 2533 PerlIO_printf(Perl_debug_log, "(%"SVf")",
2534 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
fedf30e1
DM		 2535 break;
2536
bd16a5f0 2537 default:
091ab601 2538 break;
bd16a5f0
IZ		 2539 }
2540 PerlIO_printf(Perl_debug_log, "\n");
2541 return 0;
2542}
2543
2544STATIC CV*
dc6240c9 2545S_deb_curcv(pTHX_ I32 ix)
bd16a5f0 2546{
dc6240c9
DM		 2547 PERL_SI *si = PL_curstackinfo;
2548 for (; ix >=0; ix--) {
2549 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix];
2550
2551 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2552 return cx->blk_sub.cv;
2553 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2554 return cx->blk_eval.cv;
2555 else if (ix == 0 && si->si_type == PERLSI_MAIN)
2556 return PL_main_cv;
2557 else if (ix == 0 && CxTYPE(cx) == CXt_NULL
2558 && si->si_type == PERLSI_SORT)
2559 {
2560 /* fake sort sub; use CV of caller */
2561 si = si->si_prev;
2562 ix = si->si_cxix + 1;
2563 }
2564 }
2565 return NULL;
bd16a5f0
IZ		 2566}
2567
2568void
2569Perl_watch(pTHX_ char **addr)
2570{
7918f24d
NC		 2571 PERL_ARGS_ASSERT_WATCH;
2572
bd16a5f0
IZ		 2573 PL_watchaddr = addr;
2574 PL_watchok = *addr;
2575 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2576 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2577}
2578
2579STATIC void
e1ec3a88 2580S_debprof(pTHX_ const OP *o)
bd16a5f0 2581{
7918f24d
NC		 2582 PERL_ARGS_ASSERT_DEBPROF;
2583
61f9802b 2584 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2585 return;
bd16a5f0 2586 if (!PL_profiledata)
a02a5408 2587 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ		 2588 ++PL_profiledata[o->op_type];
2589}
2590
2591void
2592Perl_debprofdump(pTHX)
2593{
2594 unsigned i;
2595 if (!PL_profiledata)
2596 return;
2597 for (i = 0; i < MAXO; i++) {
2598 if (PL_profiledata[i])
2599 PerlIO_printf(Perl_debug_log,
2600 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2601 PL_op_name[i]);
2602 }
2603}
66610fdd 2604
3b721df9 2605
66610fdd 2606/*
14d04a33 2607 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2608 */
Unnamed repository; edit this file 'description' to name the repository.