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