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
perly.y: Remove types for '$' and '*'
[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)) {
575 const GV * const gv = (const GV *)HeVAL(entry);
576 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
577 continue;
578 if (GvCVu(gv))
579 dump_sub_perl(gv, justperl);
580 if (GvFORM(gv))
581 dump_form(gv);
582 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
583 const HV * const hv = GvHV(gv);
584 if (hv && (hv != PL_defstash))
585 dump_packsubs_perl(hv, justperl); /* nested package */
586 }
587 }
588 }
589}
590
591void
592Perl_dump_sub(pTHX_ const GV *gv)
593{
594 PERL_ARGS_ASSERT_DUMP_SUB;
595 dump_sub_perl(gv, FALSE);
596}
597
598void
599Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
600{
0eb335df
BF		 601 STRLEN len;
602 SV * const sv = newSVpvs_flags("", SVs_TEMP);
603 SV *tmpsv;
604 const char * name;
36b1c95c
MH		 605
606 PERL_ARGS_ASSERT_DUMP_SUB_PERL;
607
608 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
609 return;
610
0eb335df 611 tmpsv = newSVpvs_flags("", SVs_TEMP);
36b1c95c 612 gv_fullname3(sv, gv, NULL);
0eb335df
BF		 613 name = SvPV_const(sv, len);
614 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
615 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
36b1c95c
MH		 616 if (CvISXSUB(GvCV(gv)))
617 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n",
618 PTR2UV(CvXSUB(GvCV(gv))),
619 (int)CvXSUBANY(GvCV(gv)).any_i32);
620 else if (CvROOT(GvCV(gv)))
621 op_dump(CvROOT(GvCV(gv)));
622 else
623 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
624}
625
626void
627Perl_dump_form(pTHX_ const GV *gv)
628{
629 SV * const sv = sv_newmortal();
630
631 PERL_ARGS_ASSERT_DUMP_FORM;
632
633 gv_fullname3(sv, gv, NULL);
634 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv));
635 if (CvROOT(GvFORM(gv)))
636 op_dump(CvROOT(GvFORM(gv)));
637 else
638 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
639}
640
641void
642Perl_dump_eval(pTHX)
643{
36b1c95c
MH		 644 op_dump(PL_eval_root);
645}
646
3967c732 647void
6867be6d 648Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm)
3967c732
JD		 649{
650 char ch;
651
7918f24d
NC		 652 PERL_ARGS_ASSERT_DO_PMOP_DUMP;
653
3967c732 654 if (!pm) {
cea2e8a9 655 Perl_dump_indent(aTHX_ level, file, "{}\n");
3967c732
JD		 656 return;
657 }
cea2e8a9 658 Perl_dump_indent(aTHX_ level, file, "{\n");
3967c732
JD		 659 level++;
660 if (pm->op_pmflags & PMf_ONCE)
661 ch = '?';
662 else
663 ch = '/';
aaa362c4 664 if (PM_GETRE(pm))
f87fee25
FC		 665 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n",
666 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch,
3967c732
JD		 667 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
668 else
cea2e8a9 669 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n");
20e98b0f 670 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) {
cea2e8a9 671 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = ");
20e98b0f 672 op_dump(pm->op_pmreplrootu.op_pmreplroot);
3967c732 673 }
68e2671b 674 if (pm->op_code_list) {
867940b8
DM		 675 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) {
676 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n");
677 do_op_dump(level, file, pm->op_code_list);
678 }
679 else
680 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n",
681 PTR2UV(pm->op_code_list));
68e2671b 682 }
07bc277f 683 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) {
4199688e 684 SV * const tmpsv = pm_description(pm);
b15aece3 685 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
5f954473 686 SvREFCNT_dec_NN(tmpsv);
3967c732
JD		 687 }
688
cea2e8a9 689 Perl_dump_indent(aTHX_ level-1, file, "}\n");
3967c732
JD		 690}
691
a0c2f4dd
NC		 692const struct flag_to_name pmflags_flags_names[] = {
693 {PMf_CONST, ",CONST"},
694 {PMf_KEEP, ",KEEP"},
695 {PMf_GLOBAL, ",GLOBAL"},
696 {PMf_CONTINUE, ",CONTINUE"},
697 {PMf_RETAINT, ",RETAINT"},
698 {PMf_EVAL, ",EVAL"},
699 {PMf_NONDESTRUCT, ",NONDESTRUCT"},
d63c20f2 700 {PMf_HAS_CV, ",HAS_CV"},
2a92a973
DM		 701 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"},
702 {PMf_IS_QR, ",IS_QR"}
a0c2f4dd
NC		 703};
704
b9ac451d 705static SV *
4199688e
AL		 706S_pm_description(pTHX_ const PMOP *pm)
707{
708 SV * const desc = newSVpvs("");
61f9802b 709 const REGEXP * const regex = PM_GETRE(pm);
4199688e
AL		 710 const U32 pmflags = pm->op_pmflags;
711
7918f24d
NC		 712 PERL_ARGS_ASSERT_PM_DESCRIPTION;
713
4199688e
AL		 714 if (pmflags & PMf_ONCE)
715 sv_catpv(desc, ",ONCE");
c737faaf
YO		 716#ifdef USE_ITHREADS
717 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset]))
718 sv_catpv(desc, ":USED");
719#else
720 if (pmflags & PMf_USED)
721 sv_catpv(desc, ":USED");
722#endif
c737faaf 723
68d4833d 724 if (regex) {
284167a5 725 if (RX_ISTAINTED(regex))
68d4833d 726 sv_catpv(desc, ",TAINTED");
07bc277f 727 if (RX_CHECK_SUBSTR(regex)) {
e3e400ec 728 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN))
68d4833d 729 sv_catpv(desc, ",SCANFIRST");
07bc277f 730 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL)
68d4833d
AB		 731 sv_catpv(desc, ",ALL");
732 }
dbc200c5
YO		 733 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE)
734 sv_catpv(desc, ",SKIPWHITE");
4199688e 735 }
68d4833d 736
a0c2f4dd 737 append_flags(desc, pmflags, pmflags_flags_names);
4199688e
AL		 738 return desc;
739}
740
3967c732 741void
864dbfa3 742Perl_pmop_dump(pTHX_ PMOP *pm)
3967c732
JD		 743{
744 do_pmop_dump(0, Perl_debug_log, pm);
79072805
LW		 745}
746
b6f05621
DM		 747/* Return a unique integer to represent the address of op o.
748 * If it already exists in PL_op_sequence, just return it;
749 * otherwise add it.
750 * *** Note that this isn't thread-safe */
294b3b39 751
2814eb74 752STATIC UV
0bd48802 753S_sequence_num(pTHX_ const OP *o)
2814eb74 754{
27da23d5 755 dVAR;
2814eb74
PJ		 756 SV *op,
757 **seq;
93524f2b 758 const char *key;
2814eb74 759 STRLEN len;
b6f05621
DM		 760 if (!o)
761 return 0;
c0fd1b42 762 op = newSVuv(PTR2UV(o));
b6f05621 763 sv_2mortal(op);
93524f2b 764 key = SvPV_const(op, len);
b6f05621
DM		 765 if (!PL_op_sequence)
766 PL_op_sequence = newHV();
767 seq = hv_fetch(PL_op_sequence, key, len, 0);
768 if (seq)
769 return SvUV(*seq);
770 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0);
771 return PL_op_seq;
2814eb74
PJ		 772}
773
f3574cc6
DM		 774
775
776
777
a0c2f4dd
NC		 778const struct flag_to_name op_flags_names[] = {
779 {OPf_KIDS, ",KIDS"},
780 {OPf_PARENS, ",PARENS"},
a0c2f4dd
NC		 781 {OPf_REF, ",REF"},
782 {OPf_MOD, ",MOD"},
65cccc5e 783 {OPf_STACKED, ",STACKED"},
a0c2f4dd
NC		 784 {OPf_SPECIAL, ",SPECIAL"}
785};
786
75a6ad4a 787
79072805 788void
6867be6d 789Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o)
79072805 790{
2814eb74 791 UV seq;
e15d5972
AL		 792 const OPCODE optype = o->op_type;
793
7918f24d
NC		 794 PERL_ARGS_ASSERT_DO_OP_DUMP;
795
cea2e8a9 796 Perl_dump_indent(aTHX_ level, file, "{\n");
3967c732 797 level++;
0bd48802 798 seq = sequence_num(o);
2814eb74 799 if (seq)
f5992bc4 800 PerlIO_printf(file, "%-4"UVuf, seq);
93a17b20 801 else
b6f05621 802 PerlIO_printf(file, "????");
c8db6e60
JH		 803 PerlIO_printf(file,
804 "%*sTYPE = %s ===> ",
53e06cf0 805 (int)(PL_dumpindent*level-4), "", OP_NAME(o));
2814eb74 806 if (o->op_next)
b6f05621
DM		 807 PerlIO_printf(file,
808 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n",
666ea192 809 sequence_num(o->op_next));
79072805 810 else
e75ab6ad 811 PerlIO_printf(file, "NULL\n");
11343788 812 if (o->op_targ) {
e15d5972 813 if (optype == OP_NULL) {
cea2e8a9 814 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]);
ae7d165c 815 }
8990e307 816 else
894356b3 817 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ);
8990e307 818 }
748a9306 819#ifdef DUMPADDR
57def98f 820 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next);
79072805 821#endif
a7fd8ef6 822
760f8c06
DM		 823 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) {
824 SV * const tmpsv = newSVpvs("");
825 switch (o->op_flags & OPf_WANT) {
826 case OPf_WANT_VOID:
827 sv_catpv(tmpsv, ",VOID");
828 break;
829 case OPf_WANT_SCALAR:
830 sv_catpv(tmpsv, ",SCALAR");
831 break;
832 case OPf_WANT_LIST:
833 sv_catpv(tmpsv, ",LIST");
834 break;
835 default:
836 sv_catpv(tmpsv, ",UNKNOWN");
837 break;
838 }
839 append_flags(tmpsv, o->op_flags, op_flags_names);
840 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED");
841 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE");
842 if (o->op_static) sv_catpvs(tmpsv, ",STATIC");
843 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED");
844 if (o->op_lastsib) sv_catpvs(tmpsv, ",LASTSIB");
845 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n",
846 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");
847 }
848
849 if (o->op_private) {
f3574cc6
DM		 850 U16 oppriv = o->op_private;
851 I16 op_ix = PL_op_private_bitdef_ix[o->op_type];
852 SV * tmpsv = NULL;
853
854 if (op_ix != -1) {
855 U16 stop = 0;
856 tmpsv = newSVpvs("");
857 for (; !stop; op_ix++) {
858 U16 entry = PL_op_private_bitdefs[op_ix];
859 U16 bit = (entry >> 2) & 7;
860 U16 ix = entry >> 5;
861
862 stop = (entry & 1);
863
864 if (entry & 2) {
865 /* bitfield */
866 I16 const *p = &PL_op_private_bitfields[ix];
867 U16 bitmin = (U16) *p++;
868 I16 label = *p++;
869 I16 enum_label;
870 U16 mask = 0;
871 U16 i;
872 U16 val;
873
874 for (i = bitmin; i<= bit; i++)
875 mask |= (1<<i);
876 bit = bitmin;
877 val = (oppriv & mask);
878
879 if ( label != -1
880 && PL_op_private_labels[label] == '-'
881 && PL_op_private_labels[label+1] == '\0'
882 )
883 /* display as raw number */
884 continue;
885
886 oppriv -= val;
887 val >>= bit;
888 enum_label = -1;
889 while (*p != -1) {
890 if (val == *p++) {
891 enum_label = *p;
892 break;
893 }
894 p++;
895 }
896 if (val == 0 && enum_label == -1)
897 /* don't display anonymous zero values */
898 continue;
899
900 sv_catpv(tmpsv, ",");
901 if (label != -1) {
902 sv_catpv(tmpsv, &PL_op_private_labels[label]);
903 sv_catpv(tmpsv, "=");
904 }
905 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]);
906
907 }
908 else {
909 /* bit flag */
910 if ( oppriv & (1<<bit)
911 && !(PL_op_private_labels[ix] == '-'
912 && PL_op_private_labels[ix+1] == '\0'))
913 {
914 oppriv -= (1<<bit);
915 sv_catpv(tmpsv, ",");
916 sv_catpv(tmpsv, &PL_op_private_labels[ix]);
917 }
760f8c06 918 }
760f8c06 919 }
f3574cc6
DM		 920 if (oppriv) {
921 sv_catpv(tmpsv, ",");
922 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv);
760f8c06
DM		 923 }
924 }
f3574cc6 925 if (tmpsv && SvCUR(tmpsv)) {
760f8c06
DM		 926 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1);
927 } else
928 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n",
929 (UV)oppriv);
930 }
931
e15d5972 932 switch (optype) {
971a9dd3 933 case OP_AELEMFAST:
93a17b20 934 case OP_GVSV:
79072805 935 case OP_GV:
971a9dd3 936#ifdef USE_ITHREADS
c803eecc 937 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
971a9dd3 938#else
1640e9f0 939 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */
38c076c7 940 if (cSVOPo->op_sv) {
0eb335df
BF		 941 STRLEN len;
942 const char * name;
943 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
944 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
159b6efe 945 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
0eb335df 946 name = SvPV_const(tmpsv, len);
8b6b16e7 947 Perl_dump_indent(aTHX_ level, file, "GV = %s\n",
0eb335df 948 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
38c076c7
DM		 949 }
950 else
951 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
378cc40b 952 }
971a9dd3 953#endif
79072805 954 break;
fedf30e1
DM		 955
956 case OP_MULTIDEREF:
957 {
958 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
959 UV i, count = items[-1].uv;
960
961 Perl_dump_indent(aTHX_ level, file, "ARGS = \n");
962 for (i=0; i < count; i++)
963 Perl_dump_indent(aTHX_ level+1, file, "%"UVuf" => 0x%"UVxf"\n",
964 i, items[i].uv);
965 }
966
79072805 967 case OP_CONST:
996c9baa 968 case OP_HINTSEVAL:
f5d5a27c 969 case OP_METHOD_NAMED:
7d6c333c 970 case OP_METHOD_SUPER:
810bd8b7 971 case OP_METHOD_REDIR:
972 case OP_METHOD_REDIR_SUPER:
b6a15bc5
DM		 973#ifndef USE_ITHREADS
974 /* with ITHREADS, consts are stored in the pad, and the right pad
975 * may not be active here, so skip */
b46e009d 976 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o)));
b6a15bc5 977#endif
79072805 978 break;
5e412b02
FC		 979 case OP_NULL:
980 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE)
981 break;
982 /* FALLTHROUGH */
93a17b20
LW		 983 case OP_NEXTSTATE:
984 case OP_DBSTATE:
57843af0 985 if (CopLINE(cCOPo))
f5992bc4 986 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n",
9d98dee5 987 (UV)CopLINE(cCOPo));
0eb335df
BF		 988 if (CopSTASHPV(cCOPo)) {
989 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
990 HV *stash = CopSTASH(cCOPo);
991 const char * const hvname = HvNAME_get(stash);
992
ed094faf 993 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n",
0eb335df
BF		 994 generic_pv_escape(tmpsv, hvname,
995 HvNAMELEN(stash), HvNAMEUTF8(stash)));
996 }
997 if (CopLABEL(cCOPo)) {
998 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
999 STRLEN label_len;
1000 U32 label_flags;
1001 const char *label = CopLABEL_len_flags(cCOPo,
1002 &label_len, &label_flags);
1003 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",
1004 generic_pv_escape( tmpsv, label, label_len,
1005 (label_flags & SVf_UTF8)));
1006 }
7fa99c80 1007 Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n",
947a9e0f 1008 (unsigned int)cCOPo->cop_seq);
79072805
LW		 1009 break;
1010 case OP_ENTERLOOP:
cea2e8a9 1011 Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
11343788 1012 if (cLOOPo->op_redoop)
f5992bc4 1013 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop));
79072805 1014 else
3967c732 1015 PerlIO_printf(file, "DONE\n");
cea2e8a9 1016 Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
11343788 1017 if (cLOOPo->op_nextop)
f5992bc4 1018 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop));
79072805 1019 else
3967c732 1020 PerlIO_printf(file, "DONE\n");
cea2e8a9 1021 Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
11343788 1022 if (cLOOPo->op_lastop)
f5992bc4 1023 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop));
79072805 1024 else
3967c732 1025 PerlIO_printf(file, "DONE\n");
79072805
LW		 1026 break;
1027 case OP_COND_EXPR:
1a67a97c 1028 case OP_RANGE:
a0d0e21e 1029 case OP_MAPWHILE:
79072805
LW		 1030 case OP_GREPWHILE:
1031 case OP_OR:
1032 case OP_AND:
cea2e8a9 1033 Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
11343788 1034 if (cLOGOPo->op_other)
f5992bc4 1035 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other));
79072805 1036 else
3967c732 1037 PerlIO_printf(file, "DONE\n");
79072805
LW		 1038 break;
1039 case OP_PUSHRE:
1040 case OP_MATCH:
8782bef2 1041 case OP_QR:
79072805 1042 case OP_SUBST:
3967c732 1043 do_pmop_dump(level, file, cPMOPo);
79072805 1044 break;
7934575e
GS		 1045 case OP_LEAVE:
1046 case OP_LEAVEEVAL:
1047 case OP_LEAVESUB:
1048 case OP_LEAVESUBLV:
1049 case OP_LEAVEWRITE:
1050 case OP_SCOPE:
1051 if (o->op_private & OPpREFCOUNTED)
1052 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ);
1053 break;
a0d0e21e
LW		 1054 default:
1055 break;
79072805 1056 }
11343788 1057 if (o->op_flags & OPf_KIDS) {
79072805 1058 OP *kid;
e6dae479 1059 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
3967c732 1060 do_op_dump(level, file, kid);
8d063cd8 1061 }
cea2e8a9 1062 Perl_dump_indent(aTHX_ level-1, file, "}\n");
3967c732
JD		 1063}
1064
36b1c95c
MH		 1065/*
1066=for apidoc op_dump
1067
1068Dumps the optree starting at OP C<o> to C<STDERR>.
1069
1070=cut
1071*/
1072
3967c732 1073void
6867be6d 1074Perl_op_dump(pTHX_ const OP *o)
3967c732 1075{
7918f24d 1076 PERL_ARGS_ASSERT_OP_DUMP;
3967c732 1077 do_op_dump(0, Perl_debug_log, o);
8d063cd8
LW		 1078}
1079
8adcabd8 1080void
864dbfa3 1081Perl_gv_dump(pTHX_ GV *gv)
378cc40b 1082{
0eb335df
BF		 1083 STRLEN len;
1084 const char* name;
1085 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP);
1086
378cc40b 1087
7918f24d
NC		 1088 PERL_ARGS_ASSERT_GV_DUMP;
1089
79072805 1090 if (!gv) {
760ac839 1091 PerlIO_printf(Perl_debug_log, "{}\n");
378cc40b
LW		 1092 return;
1093 }
8990e307 1094 sv = sv_newmortal();
760ac839 1095 PerlIO_printf(Perl_debug_log, "{\n");
bd61b366 1096 gv_fullname3(sv, gv, NULL);
0eb335df
BF		 1097 name = SvPV_const(sv, len);
1098 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s",
1099 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
79072805 1100 if (gv != GvEGV(gv)) {
bd61b366 1101 gv_efullname3(sv, GvEGV(gv), NULL);
0eb335df
BF		 1102 name = SvPV_const(sv, len);
1103 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s",
1104 generic_pv_escape( tmp, name, len, SvUTF8(sv) ));
8adcabd8 1105 }
3967c732 1106 PerlIO_putc(Perl_debug_log, '\n');
cea2e8a9 1107 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n");
8d063cd8
LW		 1108}
1109
14befaf4 1110
afe38520 1111/* map magic types to the symbolic names
14befaf4
DM		 1112 * (with the PERL_MAGIC_ prefixed stripped)
1113 */
1114
27da23d5 1115static const struct { const char type; const char *name; } magic_names[] = {
52f49505 1116#include "mg_names.c"
516a5887 1117 /* this null string terminates the list */
b9ac451d 1118 { 0, NULL },
14befaf4
DM		 1119};
1120
8adcabd8 1121void
6867be6d 1122Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
8d063cd8 1123{
7918f24d
NC		 1124 PERL_ARGS_ASSERT_DO_MAGIC_DUMP;
1125
3967c732 1126 for (; mg; mg = mg->mg_moremagic) {
b900a521
JH		 1127 Perl_dump_indent(aTHX_ level, file,
1128 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg));
3967c732 1129 if (mg->mg_virtual) {
bfed75c6 1130 const MGVTBL * const v = mg->mg_virtual;
2d1f1fe5
NC		 1131 if (v >= PL_magic_vtables
1132 && v < PL_magic_vtables + magic_vtable_max) {
1133 const U32 i = v - PL_magic_vtables;
1134 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]);
1135 }
3967c732 1136 else
b900a521 1137 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v));
3967c732
JD		 1138 }
1139 else
cea2e8a9 1140 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n");
8d063cd8 1141
3967c732 1142 if (mg->mg_private)
cea2e8a9 1143 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private);
3967c732 1144
14befaf4
DM		 1145 {
1146 int n;
c445ea15 1147 const char *name = NULL;
27da23d5 1148 for (n = 0; magic_names[n].name; n++) {
14befaf4
DM		 1149 if (mg->mg_type == magic_names[n].type) {
1150 name = magic_names[n].name;
1151 break;
1152 }
1153 }
1154 if (name)
1155 Perl_dump_indent(aTHX_ level, file,
1156 " MG_TYPE = PERL_MAGIC_%s\n", name);
1157 else
1158 Perl_dump_indent(aTHX_ level, file,
1159 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type);
1160 }
3967c732
JD		 1161
1162 if (mg->mg_flags) {
cea2e8a9 1163 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags);
cb50f42d
YST		 1164 if (mg->mg_type == PERL_MAGIC_envelem &&
1165 mg->mg_flags & MGf_TAINTEDDIR)
cea2e8a9 1166 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n");
4c02285a
FR		 1167 if (mg->mg_type == PERL_MAGIC_regex_global &&
1168 mg->mg_flags & MGf_MINMATCH)
1169 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
3967c732 1170 if (mg->mg_flags & MGf_REFCOUNTED)
cea2e8a9 1171 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n");
3967c732 1172 if (mg->mg_flags & MGf_GSKIP)
cea2e8a9 1173 Perl_dump_indent(aTHX_ level, file, " GSKIP\n");
4c02285a
FR		 1174 if (mg->mg_flags & MGf_COPY)
1175 Perl_dump_indent(aTHX_ level, file, " COPY\n");
1176 if (mg->mg_flags & MGf_DUP)
1177 Perl_dump_indent(aTHX_ level, file, " DUP\n");
1178 if (mg->mg_flags & MGf_LOCAL)
1179 Perl_dump_indent(aTHX_ level, file, " LOCAL\n");
25fdce4a
FC		 1180 if (mg->mg_type == PERL_MAGIC_regex_global &&
1181 mg->mg_flags & MGf_BYTES)
1182 Perl_dump_indent(aTHX_ level, file, " BYTES\n");
3967c732
JD		 1183 }
1184 if (mg->mg_obj) {
4c02285a 1185 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
28d8d7f4
YO		 1186 PTR2UV(mg->mg_obj));
1187 if (mg->mg_type == PERL_MAGIC_qr) {
07bc277f 1188 REGEXP* const re = (REGEXP *)mg->mg_obj;
61f9802b 1189 SV * const dsv = sv_newmortal();
866c78d1 1190 const char * const s
4c02285a 1191 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re),
28d8d7f4 1192 60, NULL, NULL,
95b611b0 1193 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES |
3c8556c3 1194 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0))
28d8d7f4 1195 );
6483fb35
RGS		 1196 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
1197 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n",
07bc277f 1198 (IV)RX_REFCNT(re));
28d8d7f4
YO		 1199 }
1200 if (mg->mg_flags & MGf_REFCOUNTED)
3967c732
JD		 1201 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */
1202 }
1203 if (mg->mg_len)
894356b3 1204 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len);
3967c732 1205 if (mg->mg_ptr) {
b900a521 1206 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
3967c732 1207 if (mg->mg_len >= 0) {
7e8c5dac 1208 if (mg->mg_type != PERL_MAGIC_utf8) {
17605be7 1209 SV * const sv = newSVpvs("");
7e8c5dac 1210 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
17605be7 1211 SvREFCNT_dec_NN(sv);
7e8c5dac 1212 }
3967c732
JD		 1213 }
1214 else if (mg->mg_len == HEf_SVKEY) {
1215 PerlIO_puts(file, " => HEf_SVKEY\n");
ad64d0ec
NC		 1216 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1,
1217 maxnest, dumpops, pvlim); /* MG is already +1 */
3967c732
JD		 1218 continue;
1219 }
866f9d6c 1220 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8);
3967c732 1221 else
866f9d6c
FC		 1222 PerlIO_puts(
1223 file,
1224 " ???? - " __FILE__
1225 " does not know how to handle this MG_LEN"
1226 );
3967c732
JD		 1227 PerlIO_putc(file, '\n');
1228 }
7e8c5dac 1229 if (mg->mg_type == PERL_MAGIC_utf8) {
61f9802b 1230 const STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7e8c5dac
HS		 1231 if (cache) {
1232 IV i;
1233 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
1234 Perl_dump_indent(aTHX_ level, file,
1235 " %2"IVdf": %"UVuf" -> %"UVuf"\n",
1236 i,
1237 (UV)cache[i * 2],
1238 (UV)cache[i * 2 + 1]);
1239 }
1240 }
378cc40b 1241 }
3967c732
JD		 1242}
1243
1244void
6867be6d 1245Perl_magic_dump(pTHX_ const MAGIC *mg)
3967c732 1246{
b9ac451d 1247 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0);
3967c732
JD		 1248}
1249
1250void
e1ec3a88 1251Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv)
3967c732 1252{
bfcb3514 1253 const char *hvname;
7918f24d
NC		 1254
1255 PERL_ARGS_ASSERT_DO_HV_DUMP;
1256
b900a521 1257 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
bfcb3514 1258 if (sv && (hvname = HvNAME_get(sv)))
d7d51f4b
YO		 1259 {
1260 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package
1261 name which quite legally could contain insane things like tabs, newlines, nulls or
1262 other scary crap - this should produce sane results - except maybe for unicode package
1263 names - but we will wait for someone to file a bug on that - demerphq */
0eb335df
BF		 1264 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP);
1265 PerlIO_printf(file, "\t\"%s\"\n",
1266 generic_pv_escape( tmpsv, hvname,
1267 HvNAMELEN(sv), HvNAMEUTF8(sv)));
d7d51f4b 1268 }
79072805 1269 else
3967c732
JD		 1270 PerlIO_putc(file, '\n');
1271}
1272
1273void
e1ec3a88 1274Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1275{
7918f24d
NC		 1276 PERL_ARGS_ASSERT_DO_GV_DUMP;
1277
b900a521 1278 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
0eb335df
BF		 1279 if (sv && GvNAME(sv)) {
1280 SV * const tmpsv = newSVpvs("");
1281 PerlIO_printf(file, "\t\"%s\"\n",
1282 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) ));
1283 }
c90c0ff4 1284 else
3967c732
JD		 1285 PerlIO_putc(file, '\n');
1286}
1287
1288void
e1ec3a88 1289Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv)
3967c732 1290{
7918f24d
NC		 1291 PERL_ARGS_ASSERT_DO_GVGV_DUMP;
1292
b900a521 1293 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
3967c732 1294 if (sv && GvNAME(sv)) {
0eb335df 1295 SV *tmp = newSVpvs_flags("", SVs_TEMP);
bfcb3514 1296 const char *hvname;
0eb335df
BF		 1297 HV * const stash = GvSTASH(sv);
1298 PerlIO_printf(file, "\t");
1299 /* TODO might have an extra \" here */
1300 if (stash && (hvname = HvNAME_get(stash))) {
1301 PerlIO_printf(file, "\"%s\" :: \"",
1302 generic_pv_escape(tmp, hvname,
1303 HvNAMELEN(stash), HvNAMEUTF8(stash)));
1304 }
1305 PerlIO_printf(file, "%s\"\n",
1306 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv)));
8d063cd8 1307 }
3967c732
JD		 1308 else
1309 PerlIO_putc(file, '\n');
1310}
1311
a0c2f4dd
NC		 1312const struct flag_to_name first_sv_flags_names[] = {
1313 {SVs_TEMP, "TEMP,"},
1314 {SVs_OBJECT, "OBJECT,"},
1315 {SVs_GMG, "GMG,"},
1316 {SVs_SMG, "SMG,"},
1317 {SVs_RMG, "RMG,"},
1318 {SVf_IOK, "IOK,"},
1319 {SVf_NOK, "NOK,"},
1320 {SVf_POK, "POK,"}
1321};
1322
1323const struct flag_to_name second_sv_flags_names[] = {
1324 {SVf_OOK, "OOK,"},
1325 {SVf_FAKE, "FAKE,"},
1326 {SVf_READONLY, "READONLY,"},
fd01b4b7 1327 {SVf_PROTECT, "PROTECT,"},
a0c2f4dd 1328 {SVf_BREAK, "BREAK,"},
a0c2f4dd
NC		 1329 {SVp_IOK, "pIOK,"},
1330 {SVp_NOK, "pNOK,"},
1331 {SVp_POK, "pPOK,"}
1332};
1333
ae1f06a1
NC		 1334const struct flag_to_name cv_flags_names[] = {
1335 {CVf_ANON, "ANON,"},
1336 {CVf_UNIQUE, "UNIQUE,"},
1337 {CVf_CLONE, "CLONE,"},
1338 {CVf_CLONED, "CLONED,"},
1339 {CVf_CONST, "CONST,"},
1340 {CVf_NODEBUG, "NODEBUG,"},
1341 {CVf_LVALUE, "LVALUE,"},
1342 {CVf_METHOD, "METHOD,"},
cfc1e951 1343 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"},
31d45e0c 1344 {CVf_CVGV_RC, "CVGV_RC,"},
bad4ae38 1345 {CVf_DYNFILE, "DYNFILE,"},
8fa6a409 1346 {CVf_AUTOLOAD, "AUTOLOAD,"},
e4555ecf 1347 {CVf_HASEVAL, "HASEVAL,"},
bfbc3ad9 1348 {CVf_SLABBED, "SLABBED,"},
bf9a4d2d 1349 {CVf_NAMED, "NAMED,"},
82487b59 1350 {CVf_LEXICAL, "LEXICAL,"},
31d45e0c 1351 {CVf_ISXSUB, "ISXSUB,"}
ae1f06a1
NC		 1352};
1353
1354const struct flag_to_name hv_flags_names[] = {
1355 {SVphv_SHAREKEYS, "SHAREKEYS,"},
1356 {SVphv_LAZYDEL, "LAZYDEL,"},
1357 {SVphv_HASKFLAGS, "HASKFLAGS,"},
45eaf8af 1358 {SVf_AMAGIC, "OVERLOAD,"},
ae1f06a1
NC		 1359 {SVphv_CLONEABLE, "CLONEABLE,"}
1360};
1361
1362const struct flag_to_name gp_flags_names[] = {
1363 {GVf_INTRO, "INTRO,"},
1364 {GVf_MULTI, "MULTI,"},
1365 {GVf_ASSUMECV, "ASSUMECV,"},
ae1f06a1
NC		 1366};
1367
1368const struct flag_to_name gp_flags_imported_names[] = {
1369 {GVf_IMPORTED_SV, " SV"},
1370 {GVf_IMPORTED_AV, " AV"},
1371 {GVf_IMPORTED_HV, " HV"},
1372 {GVf_IMPORTED_CV, " CV"},
1373};
1374
0d331aaf
YO		 1375/* NOTE: this structure is mostly duplicative of one generated by
1376 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1377 * the two. - Yves */
e3e400ec 1378const struct flag_to_name regexp_extflags_names[] = {
d63e6659
DM		 1379 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"},
1380 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"},
1381 {RXf_PMf_FOLD, "PMf_FOLD,"},
1382 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"},
334afb3e 1383 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"},
d63e6659 1384 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"},
41d7c59e 1385 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"},
8e1490ee 1386 {RXf_IS_ANCHORED, "IS_ANCHORED,"},
dbc200c5 1387 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"},
d63e6659 1388 {RXf_EVAL_SEEN, "EVAL_SEEN,"},
d63e6659
DM		 1389 {RXf_CHECK_ALL, "CHECK_ALL,"},
1390 {RXf_MATCH_UTF8, "MATCH_UTF8,"},
1391 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"},
1392 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"},
1393 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"},
dbc200c5 1394 {RXf_SPLIT, "SPLIT,"},
d63e6659
DM		 1395 {RXf_COPY_DONE, "COPY_DONE,"},
1396 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"},
1397 {RXf_TAINTED, "TAINTED,"},
1398 {RXf_START_ONLY, "START_ONLY,"},
dbc200c5 1399 {RXf_SKIPWHITE, "SKIPWHITE,"},
d63e6659
DM		 1400 {RXf_WHITE, "WHITE,"},
1401 {RXf_NULL, "NULL,"},
1402};
1403
0d331aaf
YO		 1404/* NOTE: this structure is mostly duplicative of one generated by
1405 * 'make regen' in regnodes.h - perhaps we should somehow integrate
1406 * the two. - Yves */
e3e400ec
YO		 1407const struct flag_to_name regexp_core_intflags_names[] = {
1408 {PREGf_SKIP, "SKIP,"},
0d331aaf
YO		 1409 {PREGf_IMPLICIT, "IMPLICIT,"},
1410 {PREGf_NAUGHTY, "NAUGHTY,"},
e3e400ec
YO		 1411 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"},
1412 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"},
0d331aaf 1413 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"},
e3e400ec 1414 {PREGf_NOSCAN, "NOSCAN,"},
0d331aaf 1415 {PREGf_CANY_SEEN, "CANY_SEEN,"},
58430ea8
YO		 1416 {PREGf_GPOS_SEEN, "GPOS_SEEN,"},
1417 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"},
8e1490ee
YO		 1418 {PREGf_ANCH_MBOL, "ANCH_MBOL,"},
1419 {PREGf_ANCH_SBOL, "ANCH_SBOL,"},
1420 {PREGf_ANCH_GPOS, "ANCH_GPOS,"},
e3e400ec
YO		 1421};
1422
3967c732 1423void
864dbfa3 1424Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim)
3967c732 1425{
cea89e20 1426 SV *d;
e1ec3a88 1427 const char *s;
3967c732
JD		 1428 U32 flags;
1429 U32 type;
1430
7918f24d
NC		 1431 PERL_ARGS_ASSERT_DO_SV_DUMP;
1432
3967c732 1433 if (!sv) {
cea2e8a9 1434 Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
3967c732 1435 return;
378cc40b 1436 }
2ef28da1 1437
3967c732
JD		 1438 flags = SvFLAGS(sv);
1439 type = SvTYPE(sv);
79072805 1440
e0bbf362
DM		 1441 /* process general SV flags */
1442
cea89e20 1443 d = Perl_newSVpvf(aTHX_
57def98f 1444 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (",
56431972 1445 PTR2UV(SvANY(sv)), PTR2UV(sv),
894356b3
GS		 1446 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv),
1447 (int)(PL_dumpindent*level), "");
8d063cd8 1448
0f94cb1f 1449 if ((flags & SVs_PADSTALE))
9a214eec 1450 sv_catpv(d, "PADSTALE,");
0f94cb1f 1451 if ((flags & SVs_PADTMP))
9a214eec 1452 sv_catpv(d, "PADTMP,");
a0c2f4dd 1453 append_flags(d, flags, first_sv_flags_names);
810b8aa5
GS		 1454 if (flags & SVf_ROK) {
1455 sv_catpv(d, "ROK,");
1456 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
1457 }
45eaf8af 1458 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,");
a0c2f4dd 1459 append_flags(d, flags, second_sv_flags_names);
7db6405c
FC		 1460 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)
1461 && type != SVt_PVAV) {
1ccdb730
NC		 1462 if (SvPCS_IMPORTED(sv))
1463 sv_catpv(d, "PCS_IMPORTED,");
1464 else
9660f481 1465 sv_catpv(d, "SCREAM,");
1ccdb730 1466 }
3967c732 1467
e0bbf362
DM		 1468 /* process type-specific SV flags */
1469
3967c732
JD		 1470 switch (type) {
1471 case SVt_PVCV:
1472 case SVt_PVFM:
ae1f06a1 1473 append_flags(d, CvFLAGS(sv), cv_flags_names);
3967c732
JD		 1474 break;
1475 case SVt_PVHV:
ae1f06a1 1476 append_flags(d, flags, hv_flags_names);
3967c732 1477 break;
926fc7b6
DM		 1478 case SVt_PVGV:
1479 case SVt_PVLV:
1480 if (isGV_with_GP(sv)) {
ae1f06a1 1481 append_flags(d, GvFLAGS(sv), gp_flags_names);
926fc7b6 1482 }
926fc7b6 1483 if (isGV_with_GP(sv) && GvIMPORTED(sv)) {
3967c732
JD		 1484 sv_catpv(d, "IMPORT");
1485 if (GvIMPORTED(sv) == GVf_IMPORTED)
1486 sv_catpv(d, "ALL,");
1487 else {
1488 sv_catpv(d, "(");
ae1f06a1 1489 append_flags(d, GvFLAGS(sv), gp_flags_imported_names);
3967c732
JD		 1490 sv_catpv(d, " ),");
1491 }
1492 }
924ba076 1493 /* FALLTHROUGH */
25da4f38 1494 default:
e604303a 1495 evaled_or_uv:
25da4f38 1496 if (SvEVALED(sv)) sv_catpv(d, "EVALED,");
69c678eb 1497 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,");
25da4f38 1498 break;
addd1794 1499 case SVt_PVMG:
c13a5c80
NC		 1500 if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
1501 if (SvVALID(sv)) sv_catpv(d, "VALID,");
924ba076 1502 /* FALLTHROUGH */
e604303a 1503 goto evaled_or_uv;
11ca45c0
NC		 1504 case SVt_PVAV:
1505 break;
3967c732 1506 }
86f0d186
NC		 1507 /* SVphv_SHAREKEYS is also 0x20000000 */
1508 if ((type != SVt_PVHV) && SvUTF8(sv))
9fe74ede 1509 sv_catpv(d, "UTF8");
3967c732 1510
b162af07
SP		 1511 if (*(SvEND(d) - 1) == ',') {
1512 SvCUR_set(d, SvCUR(d) - 1);
1513 SvPVX(d)[SvCUR(d)] = '\0';
1514 }
3967c732 1515 sv_catpv(d, ")");
b15aece3 1516 s = SvPVX_const(d);
3967c732 1517
e0bbf362
DM		 1518 /* dump initial SV details */
1519
fd0854ff 1520#ifdef DEBUG_LEAKING_SCALARS
cbe56f1d 1521 Perl_dump_indent(aTHX_ level, file,
cd676548 1522 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n",
fd0854ff
DM		 1523 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
1524 sv->sv_debug_line,
1525 sv->sv_debug_inpad ? "for" : "by",
1526 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)",
cd676548 1527 PTR2UV(sv->sv_debug_parent),
cbe56f1d
DM		 1528 sv->sv_debug_serial
1529 );
fd0854ff 1530#endif
cea2e8a9 1531 Perl_dump_indent(aTHX_ level, file, "SV = ");
e0bbf362
DM		 1532
1533 /* Dump SV type */
1534
5357ca29
NC		 1535 if (type < SVt_LAST) {
1536 PerlIO_printf(file, "%s%s\n", svtypenames[type], s);
1537
1538 if (type == SVt_NULL) {
5f954473 1539 SvREFCNT_dec_NN(d);
5357ca29
NC		 1540 return;
1541 }
1542 } else {
faccc32b 1543 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s);
5f954473 1544 SvREFCNT_dec_NN(d);
3967c732
JD		 1545 return;
1546 }
e0bbf362
DM		 1547
1548 /* Dump general SV fields */
1549
27bd069f 1550 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV
0a0c4b76
NC		 1551 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO
1552 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv))
4df7f6af 1553 || (type == SVt_IV && !SvROK(sv))) {
765f542d 1554 if (SvIsUV(sv)
f8c7b90f 1555#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC		 1556 || SvIsCOW(sv)
1557#endif
1558 )
57def98f 1559 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv));
cf2093f6 1560 else
57def98f 1561 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv));
f8c7b90f 1562#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC		 1563 if (SvIsCOW_shared_hash(sv))
1564 PerlIO_printf(file, " (HASH)");
1565 else if (SvIsCOW_normal(sv))
1566 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv));
1567#endif
3967c732
JD		 1568 PerlIO_putc(file, '\n');
1569 }
e0bbf362 1570
0f94cb1f 1571 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV
08e44740 1572 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP
c0a413d1 1573 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv))
0e4c4423 1574 || type == SVt_NV) {
e54dc35b 1575 STORE_NUMERIC_LOCAL_SET_STANDARD();
88cb8500 1576 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv));
e54dc35b 1577 RESTORE_NUMERIC_LOCAL();
3967c732 1578 }
e0bbf362 1579
3967c732 1580 if (SvROK(sv)) {
57def98f 1581 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
3967c732
JD		 1582 if (nest < maxnest)
1583 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
3967c732 1584 }
e0bbf362 1585
cea89e20 1586 if (type < SVt_PV) {
5f954473 1587 SvREFCNT_dec_NN(d);
3967c732 1588 return;
cea89e20 1589 }
e0bbf362 1590
5a3c7349
FC		 1591 if ((type <= SVt_PVLV && !isGV_with_GP(sv))
1592 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) {
8d919b0a
FC		 1593 const bool re = isREGEXP(sv);
1594 const char * const ptr =
1595 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
1596 if (ptr) {
69240efd 1597 STRLEN delta;
7a4bba22 1598 if (SvOOK(sv)) {
69240efd 1599 SvOOK_offset(sv, delta);
7a4bba22 1600 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n",
5186cc12 1601 (UV) delta);
69240efd
NC		 1602 } else {
1603 delta = 0;
7a4bba22 1604 }
8d919b0a 1605 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr));
7a4bba22
NC		 1606 if (SvOOK(sv)) {
1607 PerlIO_printf(file, "( %s . ) ",
8d919b0a 1608 pv_display(d, ptr - delta, delta, 0,
7a4bba22
NC		 1609 pvlim));
1610 }
ad3f05ad
KW		 1611 if (type == SVt_INVLIST) {
1612 PerlIO_printf(file, "\n");
1613 /* 4 blanks indents 2 beyond the PV, etc */
1614 _invlist_dump(file, level, " ", sv);
1615 }
1616 else {
685bfc3c
KW		 1617 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv),
1618 re ? 0 : SvLEN(sv),
1619 pvlim));
1620 if (SvUTF8(sv)) /* the 6? \x{....} */
1621 PerlIO_printf(file, " [UTF8 \"%s\"]",
1622 sv_uni_display(d, sv, 6 * SvCUR(sv),
1623 UNI_DISPLAY_QQ));
1624 PerlIO_printf(file, "\n");
ad3f05ad 1625 }
57def98f 1626 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv));
8d919b0a
FC		 1627 if (!re)
1628 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n",
1629 (IV)SvLEN(sv));
db2c6cb3
FC		 1630#ifdef PERL_NEW_COPY_ON_WRITE
1631 if (SvIsCOW(sv) && SvLEN(sv))
1632 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n",
1633 CowREFCNT(sv));
1634#endif
3967c732
JD		 1635 }
1636 else
cea2e8a9 1637 Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
3967c732 1638 }
e0bbf362 1639
3967c732 1640 if (type >= SVt_PVMG) {
0f94cb1f 1641 if (SvMAGIC(sv))
8530ff28 1642 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim);
3967c732
JD		 1643 if (SvSTASH(sv))
1644 do_hv_dump(level, file, " STASH", SvSTASH(sv));
c13a5c80
NC		 1645
1646 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) {
c13a5c80
NC		 1647 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv));
1648 }
3967c732 1649 }
e0bbf362
DM		 1650
1651 /* Dump type-specific SV fields */
1652
3967c732 1653 switch (type) {
3967c732 1654 case SVt_PVAV:
57def98f 1655 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
3967c732 1656 if (AvARRAY(sv) != AvALLOC(sv)) {
57def98f
JH		 1657 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv)));
1658 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv)));
3967c732
JD		 1659 }
1660 else
1661 PerlIO_putc(file, '\n');
57def98f
JH		 1662 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv));
1663 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv));
9b7476d7 1664 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n",
7db6405c 1665 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0);
76f68e9b 1666 sv_setpvs(d, "");
11ca45c0
NC		 1667 if (AvREAL(sv)) sv_catpv(d, ",REAL");
1668 if (AvREIFY(sv)) sv_catpv(d, ",REIFY");
b15aece3
SP		 1669 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n",
1670 SvCUR(d) ? SvPVX_const(d) + 1 : "");
b9f2b683 1671 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) {
c70927a6 1672 SSize_t count;
b9f2b683 1673 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) {
502c6561 1674 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0);
3967c732 1675
57def98f 1676 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count);
2ef28da1 1677 if (elt)
3967c732
JD		 1678 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim);
1679 }
1680 }
1681 break;
5d27ee4a
DD		 1682 case SVt_PVHV: {
1683 U32 usedkeys;
0c22a733
DM		 1684 if (SvOOK(sv)) {
1685 struct xpvhv_aux *const aux = HvAUX(sv);
1686 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n",
1687 (UV)aux->xhv_aux_flags);
1688 }
57def98f 1689 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv)));
5d27ee4a
DD		 1690 usedkeys = HvUSEDKEYS(sv);
1691 if (HvARRAY(sv) && usedkeys) {
3967c732
JD		 1692 /* Show distribution of HEs in the ARRAY */
1693 int freq[200];
c3caa5c3 1694#define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1))
3967c732
JD		 1695 int i;
1696 int max = 0;
5d27ee4a 1697 U32 pow2 = 2, keys = usedkeys;
65202027 1698 NV theoret, sum = 0;
3967c732
JD		 1699
1700 PerlIO_printf(file, " (");
1701 Zero(freq, FREQ_MAX + 1, int);
eb160463 1702 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) {
c445ea15
AL		 1703 HE* h;
1704 int count = 0;
3967c732
JD		 1705 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h))
1706 count++;
1707 if (count > FREQ_MAX)
1708 count = FREQ_MAX;
1709 freq[count]++;
1710 if (max < count)
1711 max = count;
1712 }
1713 for (i = 0; i <= max; i++) {
1714 if (freq[i]) {
1715 PerlIO_printf(file, "%d%s:%d", i,
1716 (i == FREQ_MAX) ? "+" : "",
1717 freq[i]);
1718 if (i != max)
1719 PerlIO_printf(file, ", ");
1720 }
1721 }
1722 PerlIO_putc(file, ')');
b8fa94d8
MG		 1723 /* The "quality" of a hash is defined as the total number of
1724 comparisons needed to access every element once, relative
1725 to the expected number needed for a random hash.
1726
1727 The total number of comparisons is equal to the sum of
e76cd0fa
AMS		 1728 the squares of the number of entries in each bucket.
1729 For a random hash of n keys into k buckets, the expected
b8fa94d8
MG		 1730 value is
1731 n + n(n-1)/2k
1732 */
1733
3967c732
JD		 1734 for (i = max; i > 0; i--) { /* Precision: count down. */
1735 sum += freq[i] * i * i;
1736 }
155aba94 1737 while ((keys = keys >> 1))
3967c732 1738 pow2 = pow2 << 1;
5d27ee4a 1739 theoret = usedkeys;
b8fa94d8 1740 theoret += theoret * (theoret-1)/pow2;
3967c732 1741 PerlIO_putc(file, '\n');
6b4667fc 1742 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100);
3967c732
JD		 1743 }
1744 PerlIO_putc(file, '\n');
5d27ee4a 1745 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys);
9faf471a
NC		 1746 {
1747 STRLEN count = 0;
1748 HE **ents = HvARRAY(sv);
1749
1750 if (ents) {
1751 HE *const *const last = ents + HvMAX(sv);
1752 count = last + 1 - ents;
1753
1754 do {
1755 if (!*ents)
1756 --count;
1757 } while (++ents <= last);
1758 }
1759
1760 if (SvOOK(sv)) {
1761 struct xpvhv_aux *const aux = HvAUX(sv);
1762 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf
1763 " (cached = %"UVuf")\n",
1764 (UV)count, (UV)aux->xhv_fill_lazy);
1765 } else {
1766 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n",
1767 (UV)count);
1768 }
1769 }
57def98f 1770 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv));
e1a7ec8d
YO		 1771 if (SvOOK(sv)) {
1772 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv));
1773 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv)));
6a5b4183 1774#ifdef PERL_HASH_RANDOMIZE_KEYS
e1a7ec8d
YO		 1775 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv));
1776 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) {
6a5b4183 1777 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv));
e1a7ec8d 1778 }
6a5b4183
YO		 1779#endif
1780 PerlIO_putc(file, '\n');
e1a7ec8d 1781 }
8d2f4536 1782 {
b9ac451d 1783 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab);
8d2f4536
NC		 1784 if (mg && mg->mg_obj) {
1785 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj));
1786 }
1787 }
bfcb3514 1788 {
b9ac451d 1789 const char * const hvname = HvNAME_get(sv);
0eb335df
BF		 1790 if (hvname) {
1791 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1792 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1793 generic_pv_escape( tmpsv, hvname,
1794 HvNAMELEN(sv), HvNAMEUTF8(sv)));
1795 }
bfcb3514 1796 }
86f55936 1797 if (SvOOK(sv)) {
ad64d0ec 1798 AV * const backrefs
85fbaab2 1799 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv));
7d88e6c4 1800 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta;
67e04715
FC		 1801 if (HvAUX(sv)->xhv_name_count)
1802 Perl_dump_indent(aTHX_
7afc2217
FC		 1803 level, file, " NAMECOUNT = %"IVdf"\n",
1804 (IV)HvAUX(sv)->xhv_name_count
67e04715 1805 );
15d9236d 1806 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) {
ec3405c8
NC		 1807 const I32 count = HvAUX(sv)->xhv_name_count;
1808 if (count) {
1809 SV * const names = newSVpvs_flags("", SVs_TEMP);
1810 /* The starting point is the first element if count is
1811 positive and the second element if count is negative. */
1812 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1813 + (count < 0 ? 1 : 0);
1814 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names
1815 + (count < 0 ? -count : count);
1816 while (hekp < endp) {
0eb335df
BF		 1817 if (HEK_LEN(*hekp)) {
1818 SV *tmp = newSVpvs_flags("", SVs_TEMP);
1819 Perl_sv_catpvf(aTHX_ names, ", \"%s\"",
1820 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp)));
ec3405c8
NC		 1821 } else {
1822 /* This should never happen. */
1823 sv_catpvs(names, ", (null)");
67e04715 1824 }
ec3405c8
NC		 1825 ++hekp;
1826 }
67e04715
FC		 1827 Perl_dump_indent(aTHX_
1828 level, file, " ENAME = %s\n", SvPV_nolen(names)+2
1829 );
1830 }
0eb335df
BF		 1831 else {
1832 SV * const tmp = newSVpvs_flags("", SVs_TEMP);
1833 const char *const hvename = HvENAME_get(sv);
67e04715 1834 Perl_dump_indent(aTHX_
0eb335df
BF		 1835 level, file, " ENAME = \"%s\"\n",
1836 generic_pv_escape(tmp, hvename,
1837 HvENAMELEN_get(sv), HvENAMEUTF8(sv)));
1838 }
67e04715 1839 }
86f55936
NC		 1840 if (backrefs) {
1841 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n",
1842 PTR2UV(backrefs));
ad64d0ec 1843 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest,
86f55936
NC		 1844 dumpops, pvlim);
1845 }
7d88e6c4 1846 if (meta) {
0eb335df
BF		 1847 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1848 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n",
1849 generic_pv_escape( tmpsv, meta->mro_which->name,
1850 meta->mro_which->length,
1851 (meta->mro_which->kflags & HVhek_UTF8)),
7d88e6c4
NC		 1852 PTR2UV(meta->mro_which));
1853 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n",
1854 (UV)meta->cache_gen);
1855 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n",
1856 (UV)meta->pkg_gen);
1857 if (meta->mro_linear_all) {
1858 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n",
1859 PTR2UV(meta->mro_linear_all));
1860 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest,
1861 dumpops, pvlim);
1862 }
1863 if (meta->mro_linear_current) {
1864 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n",
1865 PTR2UV(meta->mro_linear_current));
1866 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest,
1867 dumpops, pvlim);
1868 }
1869 if (meta->mro_nextmethod) {
1870 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n",
1871 PTR2UV(meta->mro_nextmethod));
1872 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest,
1873 dumpops, pvlim);
1874 }
1875 if (meta->isa) {
1876 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n",
1877 PTR2UV(meta->isa));
1878 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest,
1879 dumpops, pvlim);
1880 }
1881 }
86f55936 1882 }
b5698553 1883 if (nest < maxnest) {
cbab3169 1884 HV * const hv = MUTABLE_HV(sv);
b5698553
TH		 1885 STRLEN i;
1886 HE *he;
cbab3169 1887
b5698553
TH		 1888 if (HvARRAY(hv)) {
1889 int count = maxnest - nest;
1890 for (i=0; i <= HvMAX(hv); i++) {
1891 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) {
1892 U32 hash;
1893 SV * keysv;
1894 const char * keypv;
1895 SV * elt;
7dc86639 1896 STRLEN len;
b5698553
TH		 1897
1898 if (count-- <= 0) goto DONEHV;
1899
1900 hash = HeHASH(he);
1901 keysv = hv_iterkeysv(he);
1902 keypv = SvPV_const(keysv, len);
1903 elt = HeVAL(he);
cbab3169 1904
7dc86639
YO		 1905 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
1906 if (SvUTF8(keysv))
1907 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ));
b5698553
TH		 1908 if (HvEITER_get(hv) == he)
1909 PerlIO_printf(file, "[CURRENT] ");
7dc86639
YO		 1910 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash);
1911 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
1912 }
b5698553
TH		 1913 }
1914 DONEHV:;
1915 }
3967c732
JD		 1916 }
1917 break;
5d27ee4a 1918 } /* case SVt_PVHV */
e0bbf362 1919
3967c732 1920 case SVt_PVCV:
8fa6a409 1921 if (CvAUTOLOAD(sv)) {
0eb335df
BF		 1922 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1923 STRLEN len;
8fa6a409 1924 const char *const name = SvPV_const(sv, len);
0eb335df
BF		 1925 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n",
1926 generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
8fa6a409
FC		 1927 }
1928 if (SvPOK(sv)) {
0eb335df
BF		 1929 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
1930 const char *const proto = CvPROTO(sv);
1931 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n",
1932 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv),
1933 SvUTF8(sv)));
cbf82dd0 1934 }
924ba076 1935 /* FALLTHROUGH */
3967c732
JD		 1936 case SVt_PVFM:
1937 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv));
d04ba589
NC		 1938 if (!CvISXSUB(sv)) {
1939 if (CvSTART(sv)) {
1940 Perl_dump_indent(aTHX_ level, file,
1941 " START = 0x%"UVxf" ===> %"IVdf"\n",
1942 PTR2UV(CvSTART(sv)),
1943 (IV)sequence_num(CvSTART(sv)));
1944 }
1945 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n",
1946 PTR2UV(CvROOT(sv)));
1947 if (CvROOT(sv) && dumpops) {
1948 do_op_dump(level+1, file, CvROOT(sv));
1949 }
1950 } else {
126f53f3 1951 SV * const constant = cv_const_sv((const CV *)sv);
b1886099 1952
d04ba589 1953 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv)));
b1886099
NC		 1954
1955 if (constant) {
1956 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf
1957 " (CONST SV)\n",
1958 PTR2UV(CvXSUBANY(sv).any_ptr));
1959 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops,
1960 pvlim);
1961 } else {
1962 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n",
1963 (IV)CvXSUBANY(sv).any_i32);
1964 }
1965 }
3610c89f
FC		 1966 if (CvNAMED(sv))
1967 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
1968 HEK_KEY(CvNAME_HEK((CV *)sv)));
1969 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv));
57843af0 1970 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv));
bb02a38f 1971 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
894356b3 1972 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
a3985cdc 1973 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
eacbb379
DD		 1974 if (!CvISXSUB(sv)) {
1975 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
1976 if (nest < maxnest) {
1977 do_dump_pad(level+1, file, CvPADLIST(sv), 0);
1978 }
3967c732 1979 }
eacbb379 1980 else
db6e00bd 1981 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv));
3967c732 1982 {
b9ac451d 1983 const CV * const outside = CvOUTSIDE(sv);
2ef28da1 1984 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n",
57def98f 1985 PTR2UV(outside),
cf2093f6
JH		 1986 (!outside ? "null"
1987 : CvANON(outside) ? "ANON"
1988 : (outside == PL_main_cv) ? "MAIN"
1989 : CvUNIQUE(outside) ? "UNIQUE"
b24fda9d
BF		 1990 : CvGV(outside) ?
1991 generic_pv_escape(
1992 newSVpvs_flags("", SVs_TEMP),
1993 GvNAME(CvGV(outside)),
1994 GvNAMELEN(CvGV(outside)),
1995 GvNAMEUTF8(CvGV(outside)))
1996 : "UNDEFINED"));
3967c732 1997 }
704b97aa
FC		 1998 if (CvOUTSIDE(sv)
1999 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))))
ad64d0ec 2000 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim);
3967c732 2001 break;
e0bbf362 2002
926fc7b6
DM		 2003 case SVt_PVGV:
2004 case SVt_PVLV:
b9ac451d
AL		 2005 if (type == SVt_PVLV) {
2006 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv));
2007 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
2008 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
2009 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
83f78d1a 2010 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv));
305b8651 2011 if (isALPHA_FOLD_NE(LvTYPE(sv), 't'))
b9ac451d
AL		 2012 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
2013 dumpops, pvlim);
2014 }
8d919b0a 2015 if (isREGEXP(sv)) goto dumpregexp;
926fc7b6
DM		 2016 if (!isGV_with_GP(sv))
2017 break;
0eb335df
BF		 2018 {
2019 SV* tmpsv = newSVpvs_flags("", SVs_TEMP);
2020 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n",
2021 generic_pv_escape(tmpsv, GvNAME(sv),
2022 GvNAMELEN(sv),
2023 GvNAMEUTF8(sv)));
2024 }
57def98f 2025 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
3967c732 2026 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv));
be108a01 2027 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv));
57def98f 2028 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv)));
f472eb5c
GS		 2029 if (!GvGP(sv))
2030 break;
57def98f
JH		 2031 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv)));
2032 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv));
2033 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv)));
2034 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv)));
2035 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv)));
2036 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv)));
2037 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv)));
2038 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv));
008009b0
FC		 2039 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf
2040 " (%s)\n",
2041 (UV)GvGPFLAGS(sv),
2042 GvALIASED_SV(sv) ? "ALIASED_SV" : "");
57def98f 2043 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv));
b195d487 2044 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv));
3967c732
JD		 2045 do_gv_dump (level, file, " EGV", GvEGV(sv));
2046 break;
2047 case SVt_PVIO:
57def98f
JH		 2048 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv)));
2049 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv)));
2050 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv)));
2051 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv));
2052 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv));
2053 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv));
2054 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv));
27533608 2055 if (IoTOP_NAME(sv))
cea2e8a9 2056 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
9ba1f565
NC		 2057 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV)
2058 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv));
2059 else {
2060 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n",
2061 PTR2UV(IoTOP_GV(sv)));
ad64d0ec
NC		 2062 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1,
2063 maxnest, dumpops, pvlim);
9ba1f565
NC		 2064 }
2065 /* Source filters hide things that are not GVs in these three, so let's
2066 be careful out there. */
27533608 2067 if (IoFMT_NAME(sv))
cea2e8a9 2068 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
9ba1f565
NC		 2069 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV)
2070 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv));
2071 else {
2072 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n",
2073 PTR2UV(IoFMT_GV(sv)));
ad64d0ec
NC		 2074 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1,
2075 maxnest, dumpops, pvlim);
9ba1f565 2076 }
27533608 2077 if (IoBOTTOM_NAME(sv))
cea2e8a9 2078 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
9ba1f565
NC		 2079 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV)
2080 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv));
2081 else {
2082 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n",
2083 PTR2UV(IoBOTTOM_GV(sv)));
ad64d0ec
NC		 2084 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1,
2085 maxnest, dumpops, pvlim);
9ba1f565 2086 }
27533608 2087 if (isPRINT(IoTYPE(sv)))
cea2e8a9 2088 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv));
27533608 2089 else
cea2e8a9 2090 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv));
57def98f 2091 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv));
3967c732 2092 break;
206ee256 2093 case SVt_REGEXP:
8d919b0a 2094 dumpregexp:
d63e6659 2095 {
8d919b0a 2096 struct regexp * const r = ReANY((REGEXP*)sv);
e3e400ec
YO		 2097
2098#define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \
ec16d31f 2099 sv_setpv(d,""); \
e3e400ec 2100 append_flags(d, flags, names); \
ec16d31f
YO		 2101 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \
2102 SvCUR_set(d, SvCUR(d) - 1); \
2103 SvPVX(d)[SvCUR(d)] = '\0'; \
2104 } \
2105} STMT_END
e3e400ec 2106 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names);
dbc200c5
YO		 2107 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n",
2108 (UV)(r->compflags), SvPVX_const(d));
2109
e3e400ec 2110 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names);
d63e6659 2111 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n",
dbc200c5
YO		 2112 (UV)(r->extflags), SvPVX_const(d));
2113
e3e400ec
YO		 2114 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n",
2115 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" );
2116 if (r->engine == &PL_core_reg_engine) {
2117 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names);
2118 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n",
2119 (UV)(r->intflags), SvPVX_const(d));
2120 } else {
2121 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n",
d63e6659 2122 (UV)(r->intflags));
e3e400ec
YO		 2123 }
2124#undef SV_SET_STRINGIFY_REGEXP_FLAGS
d63e6659
DM		 2125 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n",
2126 (UV)(r->nparens));
2127 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n",
2128 (UV)(r->lastparen));
2129 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n",
2130 (UV)(r->lastcloseparen));
2131 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n",
2132 (IV)(r->minlen));
2133 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n",
2134 (IV)(r->minlenret));
2135 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n",
2136 (UV)(r->gofs));
2137 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n",
2138 (UV)(r->pre_prefix));
d63e6659
DM		 2139 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n",
2140 (IV)(r->sublen));
6502e081
DM		 2141 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n",
2142 (IV)(r->suboffset));
2143 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n",
2144 (IV)(r->subcoffset));
d63e6659
DM		 2145 if (r->subbeg)
2146 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n",
2147 PTR2UV(r->subbeg),
2148 pv_display(d, r->subbeg, r->sublen, 50, pvlim));
2149 else
2150 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n");
d63e6659
DM		 2151 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n",
2152 PTR2UV(r->mother_re));
01ffd0f1
FC		 2153 if (nest < maxnest && r->mother_re)
2154 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1,
2155 maxnest, dumpops, pvlim);
d63e6659
DM		 2156 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n",
2157 PTR2UV(r->paren_names));
2158 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n",
2159 PTR2UV(r->substrs));
2160 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n",
2161 PTR2UV(r->pprivate));
2162 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n",
2163 PTR2UV(r->offs));
d63c20f2
DM		 2164 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n",
2165 PTR2UV(r->qr_anoncv));
db2c6cb3 2166#ifdef PERL_ANY_COW
d63e6659
DM		 2167 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n",
2168 PTR2UV(r->saved_copy));
2169#endif
2170 }
206ee256 2171 break;
3967c732 2172 }
5f954473 2173 SvREFCNT_dec_NN(d);
3967c732
JD		 2174}
2175
36b1c95c
MH		 2176/*
2177=for apidoc sv_dump
2178
2179Dumps the contents of an SV to the C<STDERR> filehandle.
2180
2181For an example of its output, see L<Devel::Peek>.
2182
2183=cut
2184*/
2185
3967c732 2186void
864dbfa3 2187Perl_sv_dump(pTHX_ SV *sv)
3967c732 2188{
7918f24d
NC		 2189 PERL_ARGS_ASSERT_SV_DUMP;
2190
d1029faa
JP		 2191 if (SvROK(sv))
2192 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0);
2193 else
2194 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0);
8d063cd8 2195}
bd16a5f0
IZ		 2196
2197int
2198Perl_runops_debug(pTHX)
2199{
2200 if (!PL_op) {
9b387841 2201 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
bd16a5f0
IZ		 2202 return 0;
2203 }
2204
9f3673fb 2205 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
bd16a5f0 2206 do {
75d476e2
S		 2207#ifdef PERL_TRACE_OPS
2208 ++PL_op_exec_cnt[PL_op->op_type];
2209#endif
bd16a5f0 2210 if (PL_debug) {
b9ac451d 2211 if (PL_watchaddr && (*PL_watchaddr != PL_watchok))
bd16a5f0
IZ		 2212 PerlIO_printf(Perl_debug_log,
2213 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
2214 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
2215 PTR2UV(*PL_watchaddr));
d6721266
DM		 2216 if (DEBUG_s_TEST_) {
2217 if (DEBUG_v_TEST_) {
2218 PerlIO_printf(Perl_debug_log, "\n");
2219 deb_stack_all();
2220 }
2221 else
2222 debstack();
2223 }
2224
2225
bd16a5f0
IZ		 2226 if (DEBUG_t_TEST_) debop(PL_op);
2227 if (DEBUG_P_TEST_) debprof(PL_op);
2228 }
fe83c362
SM		 2229
2230 OP_ENTRY_PROBE(OP_NAME(PL_op));
16c91539 2231 } while ((PL_op = PL_op->op_ppaddr(aTHX)));
9f3673fb 2232 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
47c9d59f 2233 PERL_ASYNC_CHECK();
bd16a5f0
IZ		 2234
2235 TAINT_NOT;
2236 return 0;
2237}
2238
f9b02e42
DM		 2239
2240/* print the names of the n lexical vars starting at pad offset off */
2241
2242void
2243S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren)
2244{
2245 PADNAME *sv;
2246 CV * const cv = deb_curcv(cxstack_ix);
2247 PADNAMELIST *comppad = NULL;
2248 int i;
2249
2250 if (cv) {
2251 PADLIST * const padlist = CvPADLIST(cv);
2252 comppad = PadlistNAMES(padlist);
2253 }
2254 if (paren)
2255 PerlIO_printf(Perl_debug_log, "(");
2256 for (i = 0; i < n; i++) {
2257 if (comppad && (sv = padnamelist_fetch(comppad, off + i)))
2258 PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv));
2259 else
2260 PerlIO_printf(Perl_debug_log, "[%"UVuf"]",
2261 (UV)(off+i));
2262 if (i < n - 1)
2263 PerlIO_printf(Perl_debug_log, ",");
2264 }
2265 if (paren)
2266 PerlIO_printf(Perl_debug_log, ")");
2267}
2268
2269
fedf30e1
DM		 2270/* append to the out SV, the name of the lexical at offset off in the CV
2271 * cv */
2272
ec48399d 2273static void
fedf30e1
DM		 2274S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n,
2275 bool paren, bool is_scalar)
2276{
2277 PADNAME *sv;
2278 PADNAMELIST *namepad = NULL;
2279 int i;
2280
2281 if (cv) {
2282 PADLIST * const padlist = CvPADLIST(cv);
2283 namepad = PadlistNAMES(padlist);
2284 }
2285
2286 if (paren)
2287 sv_catpvs_nomg(out, "(");
2288 for (i = 0; i < n; i++) {
2289 if (namepad && (sv = padnamelist_fetch(namepad, off + i)))
2290 {
2291 STRLEN cur = SvCUR(out);
26334c4d
FC		 2292 Perl_sv_catpvf(aTHX_ out, "[%"UTF8f,
2293 UTF8fARG(1, PadnameLEN(sv) - 1,
2294 PadnamePV(sv) + 1));
fedf30e1
DM		 2295 if (is_scalar)
2296 SvPVX(out)[cur] = '$';
2297 }
2298 else
2299 Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i));
2300 if (i < n - 1)
2301 sv_catpvs_nomg(out, ",");
2302 }
2303 if (paren)
2304 sv_catpvs_nomg(out, "(");
2305}
2306
2307
ec48399d 2308static void
8bbe2fa8 2309S_append_gv_name(pTHX_ GV *gv, SV *out)
fedf30e1
DM		 2310{
2311 SV *sv;
2312 if (!gv) {
2313 sv_catpvs_nomg(out, "<NULLGV>");
2314 return;
2315 }
2316 sv = newSV(0);
2317 gv_fullname4(sv, gv, NULL, FALSE);
8bbe2fa8 2318 Perl_sv_catpvf(aTHX_ out, "%c%-p", '$', sv);
fedf30e1
DM		 2319 SvREFCNT_dec_NN(sv);
2320}
2321
2322#ifdef USE_ITHREADS
2323# define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);
2324#else
2325# define ITEM_SV(item) UNOP_AUX_item_sv(item)
2326#endif
2327
2328
2329/* return a temporary SV containing a stringified representation of
48ee9c0e 2330 * the op_aux field of a MULTIDEREF op, associated with CV cv
fedf30e1
DM		 2331 */
2332
2333SV*
48ee9c0e 2334Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
fedf30e1
DM		 2335{
2336 UNOP_AUX_item *items = cUNOP_AUXo->op_aux;
2337 UV actions = items->uv;
2338 SV *sv;
2339 bool last = 0;
2340 bool is_hash = FALSE;
2341 int derefs = 0;
ff94d24c 2342 SV *out = newSVpvn_flags("",0,SVs_TEMP);
fedf30e1
DM		 2343#ifdef USE_ITHREADS
2344 PADLIST * const padlist = CvPADLIST(cv);
500f40f5 2345 PAD *comppad = PadlistARRAY(padlist)[1];
fedf30e1
DM		 2346#endif
2347
48ee9c0e 2348 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY;
fedf30e1
DM		 2349
2350 while (!last) {
2351 switch (actions & MDEREF_ACTION_MASK) {
2352
2353 case MDEREF_reload:
2354 actions = (++items)->uv;
2355 continue;
2356
2357 case MDEREF_HV_padhv_helem:
2358 is_hash = TRUE;
2359 case MDEREF_AV_padav_aelem:
2360 derefs = 1;
2361 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2362 goto do_elem;
2363
2364 case MDEREF_HV_gvhv_helem:
2365 is_hash = TRUE;
2366 case MDEREF_AV_gvav_aelem:
2367 derefs = 1;
2368 sv = ITEM_SV(++items);
8bbe2fa8 2369 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM		 2370 goto do_elem;
2371
2372 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
2373 is_hash = TRUE;
2374 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
2375 sv = ITEM_SV(++items);
8bbe2fa8 2376 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM		 2377 goto do_vivify_rv2xv_elem;
2378
2379 case MDEREF_HV_padsv_vivify_rv2hv_helem:
2380 is_hash = TRUE;
2381 case MDEREF_AV_padsv_vivify_rv2av_aelem:
2382 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2383 goto do_vivify_rv2xv_elem;
2384
2385 case MDEREF_HV_pop_rv2hv_helem:
2386 case MDEREF_HV_vivify_rv2hv_helem:
2387 is_hash = TRUE;
2388 do_vivify_rv2xv_elem:
2389 case MDEREF_AV_pop_rv2av_aelem:
2390 case MDEREF_AV_vivify_rv2av_aelem:
2391 if (!derefs++)
2392 sv_catpvs_nomg(out, "->");
2393 do_elem:
2394 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) {
2395 sv_catpvs_nomg(out, "->");
2396 last = 1;
2397 break;
2398 }
2399
2400 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1);
2401 switch (actions & MDEREF_INDEX_MASK) {
2402 case MDEREF_INDEX_const:
2403 if (is_hash) {
2404 STRLEN cur;
2405 char *s;
2406 sv = ITEM_SV(++items);
2407 s = SvPV(sv, cur);
2408 pv_pretty(out, s, cur, 30,
2409 NULL, NULL,
2410 (PERL_PV_PRETTY_NOCLEAR
2411 |PERL_PV_PRETTY_QUOTE
2412 |PERL_PV_PRETTY_ELLIPSES));
2413 }
2414 else
2415 Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv);
2416 break;
2417 case MDEREF_INDEX_padsv:
2418 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1);
2419 break;
2420 case MDEREF_INDEX_gvsv:
2421 sv = ITEM_SV(++items);
8bbe2fa8 2422 S_append_gv_name(aTHX_ (GV*)sv, out);
fedf30e1
DM		 2423 break;
2424 }
2425 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1);
2426
2427 if (actions & MDEREF_FLAG_last)
2428 last = 1;
2429 is_hash = FALSE;
2430
2431 break;
2432
2433 default:
2434 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)",
2435 (int)(actions & MDEREF_ACTION_MASK));
2436 last = 1;
2437 break;
2438
2439 } /* switch */
2440
2441 actions >>= MDEREF_SHIFT;
2442 } /* while */
2443 return out;
2444}
2445
2446
bd16a5f0 2447I32
6867be6d 2448Perl_debop(pTHX_ const OP *o)
bd16a5f0 2449{
7918f24d
NC		 2450 PERL_ARGS_ASSERT_DEBOP;
2451
1045810a
IZ		 2452 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
2453 return 0;
2454
bd16a5f0
IZ		 2455 Perl_deb(aTHX_ "%s", OP_NAME(o));
2456 switch (o->op_type) {
2457 case OP_CONST:
996c9baa 2458 case OP_HINTSEVAL:
6cefa69e 2459 /* With ITHREADS, consts are stored in the pad, and the right pad
7367e658 2460 * may not be active here, so check.
6cefa69e 2461 * Looks like only during compiling the pads are illegal.
7367e658 2462 */
6cefa69e
RU		 2463#ifdef USE_ITHREADS
2464 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME)
2465#endif
7367e658 2466 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
bd16a5f0
IZ		 2467 break;
2468 case OP_GVSV:
2469 case OP_GV:
8333ca1a 2470 if (cGVOPo_gv && isGV(cGVOPo_gv)) {
b9ac451d 2471 SV * const sv = newSV(0);
bd61b366 2472 gv_fullname3(sv, cGVOPo_gv, NULL);
93524f2b 2473 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
5f954473 2474 SvREFCNT_dec_NN(sv);
bd16a5f0 2475 }
8333ca1a
FC		 2476 else if (cGVOPo_gv) {
2477 SV * const sv = newSV(0);
2478 assert(SvROK(cGVOPo_gv));
2479 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
2480 PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
ecf05a58 2481 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
8333ca1a
FC		 2482 SvREFCNT_dec_NN(sv);
2483 }
bd16a5f0
IZ		 2484 else
2485 PerlIO_printf(Perl_debug_log, "(NULL)");
2486 break;
a7fd8ef6 2487
bd16a5f0
IZ		 2488 case OP_PADSV:
2489 case OP_PADAV:
2490 case OP_PADHV:
f9b02e42
DM		 2491 S_deb_padvar(aTHX_ o->op_targ, 1, 1);
2492 break;
fedf30e1 2493
a7fd8ef6 2494 case OP_PADRANGE:
f9b02e42
DM		 2495 S_deb_padvar(aTHX_ o->op_targ,
2496 o->op_private & OPpPADRANGE_COUNTMASK, 1);
bd16a5f0 2497 break;
a7fd8ef6 2498
fedf30e1
DM		 2499 case OP_MULTIDEREF:
2500 PerlIO_printf(Perl_debug_log, "(%-p)",
48ee9c0e 2501 multideref_stringify(o, deb_curcv(cxstack_ix)));
fedf30e1
DM		 2502 break;
2503
bd16a5f0 2504 default:
091ab601 2505 break;
bd16a5f0
IZ		 2506 }
2507 PerlIO_printf(Perl_debug_log, "\n");
2508 return 0;
2509}
2510
2511STATIC CV*
61f9802b 2512S_deb_curcv(pTHX_ const I32 ix)
bd16a5f0 2513{
b9ac451d 2514 const PERL_CONTEXT * const cx = &cxstack[ix];
bd16a5f0
IZ		 2515 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2516 return cx->blk_sub.cv;
2517 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
676a678a 2518 return cx->blk_eval.cv;
bd16a5f0
IZ		 2519 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
2520 return PL_main_cv;
2521 else if (ix <= 0)
601f1833 2522 return NULL;
bd16a5f0
IZ		 2523 else
2524 return deb_curcv(ix - 1);
2525}
2526
2527void
2528Perl_watch(pTHX_ char **addr)
2529{
7918f24d
NC		 2530 PERL_ARGS_ASSERT_WATCH;
2531
bd16a5f0
IZ		 2532 PL_watchaddr = addr;
2533 PL_watchok = *addr;
2534 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
2535 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
2536}
2537
2538STATIC void
e1ec3a88 2539S_debprof(pTHX_ const OP *o)
bd16a5f0 2540{
7918f24d
NC		 2541 PERL_ARGS_ASSERT_DEBPROF;
2542
61f9802b 2543 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash))
1045810a 2544 return;
bd16a5f0 2545 if (!PL_profiledata)
a02a5408 2546 Newxz(PL_profiledata, MAXO, U32);
bd16a5f0
IZ		 2547 ++PL_profiledata[o->op_type];
2548}
2549
2550void
2551Perl_debprofdump(pTHX)
2552{
2553 unsigned i;
2554 if (!PL_profiledata)
2555 return;
2556 for (i = 0; i < MAXO; i++) {
2557 if (PL_profiledata[i])
2558 PerlIO_printf(Perl_debug_log,
2559 "%5lu %s\n", (unsigned long)PL_profiledata[i],
2560 PL_op_name[i]);
2561 }
2562}
66610fdd 2563
3b721df9 2564
66610fdd
RGS		 2565/*
2566 * Local variables:
2567 * c-indentation-style: bsd
2568 * c-basic-offset: 4
14d04a33 2569 * indent-tabs-mode: nil
66610fdd
RGS		 2570 * End:
2571 *
14d04a33 2572 * ex: set ts=8 sts=4 sw=4 et:
37442d52 2573 */
Unnamed repository; edit this file 'description' to name the repository.